ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Net-IRC3/lib/Net/IRC3/Util.pm
Revision: 1.10
Committed: Sun Feb 25 10:58:59 2007 UTC (17 years, 9 months ago) by elmex
Branch: MAIN
Changes since 1.9: +1 -1 lines
Log Message:
raised kwalitee score and raised coverage of the tests a bit.

File Contents

# Content
1 package Net::IRC3::Util;
2 use strict;
3 no warnings;
4 use Exporter;
5 our @ISA = qw/Exporter/;
6 our @EXPORT_OK =
7 qw(mk_msg parse_irc_msg split_prefix prefix_nick
8 decode_ctcp filter_ctcp_text_attr prefix_user prefix_host
9 rfc_code_to_name);
10
11 =head1 NAME
12
13 Net::IRC3::Util - Common utilities that help with IRC protocol handling
14
15 =head1 SYNOPSIS
16
17 use Net::IRC3 qw/parse_irc_msg mk_msg/;
18
19 my $msgdata = mk_msg (undef, PRIVMSG => "my hands glow!", "mcmanus");
20
21 =head1 FUNCTIONS
22
23 These are some utility functions that might come in handy when
24 handling the IRC protocol.
25
26 You can export these with eg.:
27
28 use Net::IRC3 qw/parse_irc_msg/;
29
30 =over 4
31
32 =item B<parse_irc_msg ($ircline)>
33
34 This method parses the C<$ircline>, which is one line of the IRC protocol
35 without the trailing "\015\012".
36
37 It returns a hash which has the following entrys:
38
39 =over 4
40
41 =item prefix
42
43 The message prefix.
44
45 =item command
46
47 The IRC command.
48
49 =item params
50
51 The parameters to the IRC command in a array reference,
52 this includes the trailing parameter (the one after the ':' or
53 the 14th parameter).
54
55 =item trailing
56
57 This is set if there was a trailing parameter (the one after the ':' or
58 the 14th parameter).
59
60 =back
61
62 =cut
63
64 sub parse_irc_msg {
65 my ($msg) = @_;
66
67 my $cmd;
68 my $pref;
69 my $t;
70 my @a;
71
72 my $p = $msg =~ s/^(:([^ ]+)[ ])?([A-Za-z]+|\d{3})//;
73 $pref = $2;
74 $cmd = $3;
75
76 my $i = 0;
77
78 while ($msg =~ s/^[ ]([^ :\015\012\0][^ \015\012\0]*)//) {
79
80 push @a, $1 if defined $1;
81 if (++$i > 13) { last; }
82 }
83
84 if ($i == 14) {
85
86 if ($msg =~ s/^[ ]:?([^\015\012\0]*)//) {
87 $t = $1 if $1 ne "";
88 }
89
90 } else {
91
92 if ($msg =~ s/^[ ]:([^\015\012\0]*)//) {
93 $t = $1 if $1 ne "";
94 }
95 }
96
97 push @a, $t if defined $t;
98
99 my $m = { prefix => $pref, command => $cmd, params => \@a, trailing => $t };
100 return $p ? $m : undef;
101 }
102
103 =item B<mk_msg ($prefix, $command, $trailing, @params)>
104
105 This function assembles a IRC message. The generated
106 message will look like (pseudo code!)
107
108 :<prefix> <command> <params> :<trail>
109
110 Please refer to RFC 2812 how IRC messages normally look like.
111
112 The prefix and the trailing string will be omitted if they are C<undef>.
113
114 EXAMPLES:
115
116 mk_msg (undef, "PRIVMSG", "you suck!", "magnus");
117 # will return: "PRIVMSG magnus :you suck!\015\012"
118
119 mk_msg (undef, "JOIN", undef, "#test");
120 # will return: "JOIN #test\015\012"
121
122 =cut
123
124 sub mk_msg {
125 my ($prefix, $command, $trail, @params) = @_;
126 my $msg = "";
127
128 $msg .= defined $prefix ? ":$prefix " : "";
129 $msg .= "$command";
130
131 # FIXME: params must be counted, and if > 13 they have to be
132 # concationated with $trail
133 map { $msg .= " $_" } @params;
134
135 $msg .= defined $trail ? " :$trail" : "";
136 $msg .= "\015\012";
137
138 return $msg;
139 }
140
141
142 =item B<decode_ctcp ($line)>
143
144 TODO
145
146 =cut
147
148 sub decode_ctcp {
149 my ($line) = @_;
150
151 while ($line =~ /\G\001([^\001]*)\001/g) {
152 my $req = $1;
153 }
154
155 $line =~ s/\001[^\001]*\001//g;
156
157 return $line;
158 }
159
160 =item B<filter_ctcp_text_attr ($line, $cb)>
161
162 TODO
163
164 =cut
165 # implemented after the below CTCP spec, but
166 # doesnt seem to be used by anyone... so it's untested.
167 sub filter_ctcp_text_attr {
168 my ($line, $cb) = @_;
169 return unless $cb;
170 $line =~ s/\006([BVUSI])/{warn "FIL\n"; my $c = $cb->($1); defined $c ? $c : "\006$1"}/ieg;
171 $line =~ s/\006CA((?:I[0-9A-F]|#[0-9A-F]{3}){2})/{my $c = $cb->($1); defined $c ? $c : "\006CA$1"}/ieg;
172 $line =~ s/\006C([FB])(I[0-9A-F]|#[0-9A-F]{3})/{my $c = $cb->($1, $2); defined $c ? $c : "\006C$1$2"}/ieg;
173 $line =~ s/\006CX([AFB])/{my $c = $cb->($1); defined $c ? $c : "\006CX$1"}/ieg;
174 return $line;
175 }
176
177 =item B<split_prefix ($prefix)>
178
179 This function splits an IRC user prefix as described by RFC 2817
180 into the three parts: nickname, user and host. Which will be
181 returned as a list with that order.
182
183 C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.
184
185 =cut
186
187 sub split_prefix {
188 my ($prfx) = @_;
189
190 if (ref ($prfx) eq 'HASH') {
191 $prfx = $prfx->{prefix};
192 }
193
194 $prfx =~ m/^\s*([^!]*)!([^@]*)@(.*?)\s*$/;
195 return ($1, $2, $3);
196 }
197
198 =item B<prefix_nick ($prefix)>
199
200 A shortcut to extract the nickname from the C<$prefix>.
201
202 C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.
203
204 =cut
205
206 sub prefix_nick {
207 my ($prfx) = @_;
208 return (split_prefix ($prfx))[0];
209 }
210
211 =item B<prefix_user ($prefix)>
212
213 A shortcut to extract the username from the C<$prefix>.
214
215 C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.
216
217 =cut
218
219 sub prefix_user {
220 my ($prfx) = @_;
221 return (split_prefix ($prfx))[1];
222 }
223
224 =item B<prefix_host ($prefix)>
225
226 A shortcut to extract the hostname from the C<$prefix>.
227
228 C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.
229
230 =cut
231
232 sub prefix_host {
233 my ($prfx) = @_;
234 return (split_prefix ($prfx))[2];
235 }
236
237
238 =item B<rfc_code_to_name ($code)>
239
240 This function is a interface to the internal mapping or numeric
241 replies to the reply name in RFC 2812 (which you may also consult).
242
243 C<$code> is returned if no name for C<$code> exists
244 (as some server may extended the protocol).
245
246 =back
247
248 =cut
249
250 our %RFC_NUMCODE_MAP = (
251 '001' => 'RPL_WELCOME',
252 '002' => 'RPL_YOURHOST',
253 '003' => 'RPL_CREATED',
254 '004' => 'RPL_MYINFO',
255 '005' => 'RPL_BOUNCE',
256 '200' => 'RPL_TRACELINK',
257 '201' => 'RPL_TRACECONNECTING',
258 '202' => 'RPL_TRACEHANDSHAKE',
259 '203' => 'RPL_TRACEUNKNOWN',
260 '204' => 'RPL_TRACEOPERATOR',
261 '205' => 'RPL_TRACEUSER',
262 '206' => 'RPL_TRACESERVER',
263 '207' => 'RPL_TRACESERVICE',
264 '208' => 'RPL_TRACENEWTYPE',
265 '209' => 'RPL_TRACECLASS',
266 '210' => 'RPL_TRACERECONNECT',
267 '211' => 'RPL_STATSLINKINFO',
268 '212' => 'RPL_STATSCOMMANDS',
269 '219' => 'RPL_ENDOFSTATS',
270 '221' => 'RPL_UMODEIS',
271 '233' => 'RPL_SERVICE',
272 '234' => 'RPL_SERVLIST',
273 '235' => 'RPL_SERVLISTEND',
274 '242' => 'RPL_STATSUPTIME',
275 '243' => 'RPL_STATSOLINE',
276 '250' => 'RPL_STATSDLINE',
277 '251' => 'RPL_LUSERCLIENT',
278 '252' => 'RPL_LUSEROP',
279 '253' => 'RPL_LUSERUNKNOWN',
280 '254' => 'RPL_LUSERCHANNELS',
281 '255' => 'RPL_LUSERME',
282 '256' => 'RPL_ADMINME',
283 '257' => 'RPL_ADMINLOC1',
284 '258' => 'RPL_ADMINLOC2',
285 '259' => 'RPL_ADMINEMAIL',
286 '261' => 'RPL_TRACELOG',
287 '262' => 'RPL_TRACEEND',
288 '263' => 'RPL_TRYAGAIN',
289 '301' => 'RPL_AWAY',
290 '302' => 'RPL_USERHOST',
291 '303' => 'RPL_ISON',
292 '305' => 'RPL_UNAWAY',
293 '306' => 'RPL_NOWAWAY',
294 '311' => 'RPL_WHOISUSER',
295 '312' => 'RPL_WHOISSERVER',
296 '313' => 'RPL_WHOISOPERATOR',
297 '314' => 'RPL_WHOWASUSER',
298 '315' => 'RPL_ENDOFWHO',
299 '317' => 'RPL_WHOISIDLE',
300 '318' => 'RPL_ENDOFWHOIS',
301 '319' => 'RPL_WHOISCHANNELS',
302 '321' => 'RPL_LISTSTART',
303 '322' => 'RPL_LIST',
304 '323' => 'RPL_LISTEND',
305 '324' => 'RPL_CHANNELMODEIS',
306 '325' => 'RPL_UNIQOPIS',
307 '331' => 'RPL_NOTOPIC',
308 '332' => 'RPL_TOPIC',
309 '341' => 'RPL_INVITING',
310 '342' => 'RPL_SUMMONING',
311 '346' => 'RPL_INVITELIST',
312 '347' => 'RPL_ENDOFINVITELIST',
313 '348' => 'RPL_EXCEPTLIST',
314 '349' => 'RPL_ENDOFEXCEPTLIST',
315 '351' => 'RPL_VERSION',
316 '352' => 'RPL_WHOREPLY',
317 '353' => 'RPL_NAMREPLY',
318 '364' => 'RPL_LINKS',
319 '365' => 'RPL_ENDOFLINKS',
320 '366' => 'RPL_ENDOFNAMES',
321 '367' => 'RPL_BANLIST',
322 '368' => 'RPL_ENDOFBANLIST',
323 '369' => 'RPL_ENDOFWHOWAS',
324 '371' => 'RPL_INFO',
325 '372' => 'RPL_MOTD',
326 '374' => 'RPL_ENDOFINFO',
327 '375' => 'RPL_MOTDSTART',
328 '376' => 'RPL_ENDOFMOTD',
329 '381' => 'RPL_YOUREOPER',
330 '382' => 'RPL_REHASHING',
331 '383' => 'RPL_YOURESERVICE',
332 '384' => 'RPL_MYPORTIS',
333 '391' => 'RPL_TIME',
334 '392' => 'RPL_USERSSTART',
335 '393' => 'RPL_USERS',
336 '394' => 'RPL_ENDOFUSERS',
337 '395' => 'RPL_NOUSERS',
338 '401' => 'ERR_NOSUCHNICK',
339 '402' => 'ERR_NOSUCHSERVER',
340 '403' => 'ERR_NOSUCHCHANNEL',
341 '404' => 'ERR_CANNOTSENDTOCHAN',
342 '405' => 'ERR_TOOMANYCHANNELS',
343 '406' => 'ERR_WASNOSUCHNICK',
344 '407' => 'ERR_TOOMANYTARGETS',
345 '408' => 'ERR_NOSUCHSERVICE',
346 '409' => 'ERR_NOORIGIN',
347 '411' => 'ERR_NORECIPIENT',
348 '412' => 'ERR_NOTEXTTOSEND',
349 '413' => 'ERR_NOTOPLEVEL',
350 '414' => 'ERR_WILDTOPLEVEL',
351 '415' => 'ERR_BADMASK',
352 '421' => 'ERR_UNKNOWNCOMMAND',
353 '422' => 'ERR_NOMOTD',
354 '423' => 'ERR_NOADMININFO',
355 '424' => 'ERR_FILEERROR',
356 '431' => 'ERR_NONICKNAMEGIVEN',
357 '432' => 'ERR_ERRONEUSNICKNAME',
358 '433' => 'ERR_NICKNAMEINUSE',
359 '436' => 'ERR_NICKCOLLISION',
360 '437' => 'ERR_UNAVAILRESOURCE',
361 '441' => 'ERR_USERNOTINCHANNEL',
362 '442' => 'ERR_NOTONCHANNEL',
363 '443' => 'ERR_USERONCHANNEL',
364 '444' => 'ERR_NOLOGIN',
365 '445' => 'ERR_SUMMONDISABLED',
366 '446' => 'ERR_USERSDISABLED',
367 '451' => 'ERR_NOTREGISTERED',
368 '461' => 'ERR_NEEDMOREPARAMS',
369 '462' => 'ERR_ALREADYREGISTRED',
370 '463' => 'ERR_NOPERMFORHOST',
371 '464' => 'ERR_PASSWDMISMATCH',
372 '465' => 'ERR_YOUREBANNEDCREEP',
373 '466' => 'ERR_YOUWILLBEBANNED',
374 '467' => 'ERR_KEYSET',
375 '471' => 'ERR_CHANNELISFULL',
376 '472' => 'ERR_UNKNOWNMODE',
377 '473' => 'ERR_INVITEONLYCHAN',
378 '474' => 'ERR_BANNEDFROMCHAN',
379 '475' => 'ERR_BADCHANNELKEY',
380 '476' => 'ERR_BADCHANMASK',
381 '477' => 'ERR_NOCHANMODES',
382 '478' => 'ERR_BANLISTFULL',
383 '481' => 'ERR_NOPRIVILEGES',
384 '482' => 'ERR_CHANOPRIVSNEEDED',
385 '483' => 'ERR_CANTKILLSERVER',
386 '484' => 'ERR_RESTRICTED',
387 '485' => 'ERR_UNIQOPPRIVSNEEDED',
388 '491' => 'ERR_NOOPERHOST',
389 '492' => 'ERR_NOSERVICEHOST',
390 '501' => 'ERR_UMODEUNKNOWNFLAG',
391 '502' => 'ERR_USERSDONTMATCH',
392 );
393
394 sub rfc_code_to_name {
395 my ($code) = @_;
396 return $RFC_NUMCODE_MAP{$code} || $code;
397 }
398
399 =head1 AUTHOR
400
401 Robin Redeker, C<< <elmex@ta-sa.org> >>
402
403 =head1 SEE ALSO
404
405 Internet Relay Chat Client To Client Protocol from February 2, 1997
406 http://www.invlogic.com/irc/ctcp.html
407
408 RFC 2812 - Internet Relay Chat: Client Protocol
409
410 =head1 COPYRIGHT & LICENSE
411
412 Copyright 2006 Robin Redeker, all rights reserved.
413
414 This program is free software; you can redistribute it and/or modify it
415 under the same terms as Perl itself.
416
417 =cut
418
419 1;