ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Net-IRC3/lib/Net/IRC3/Util.pm
Revision: 1.12
Committed: Wed Apr 18 21:10:21 2007 UTC (17 years, 7 months ago) by elmex
Branch: MAIN
Changes since 1.11: +73 -3 lines
Log Message:
added CTCP support

File Contents

# User Rev Content
1 elmex 1.1 package Net::IRC3::Util;
2     use strict;
3 elmex 1.9 no warnings;
4 elmex 1.1 use Exporter;
5     our @ISA = qw/Exporter/;
6     our @EXPORT_OK =
7     qw(mk_msg parse_irc_msg split_prefix prefix_nick
8 elmex 1.12 decode_ctcp encode_ctcp filter_ctcp_text_attr prefix_user prefix_host
9 elmex 1.7 rfc_code_to_name);
10 elmex 1.1
11     =head1 NAME
12    
13     Net::IRC3::Util - Common utilities that help with IRC protocol handling
14    
15 elmex 1.2 =head1 SYNOPSIS
16    
17     use Net::IRC3 qw/parse_irc_msg mk_msg/;
18    
19 elmex 1.7 my $msgdata = mk_msg (undef, PRIVMSG => "my hands glow!", "mcmanus");
20 elmex 1.2
21 elmex 1.1 =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 elmex 1.5 # will return: "JOIN #test\015\012"
121 elmex 1.1
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 elmex 1.8 =item B<decode_ctcp ($line)>
143    
144     TODO
145 elmex 1.1
146     =cut
147    
148 elmex 1.12 my @_ctcp_lowlevel_escape = ("\000", "0", "\012", "n", "\015", "r", "\020", "\020");
149    
150     sub unescape_lowlevel {
151     my ($data) = @_;
152     my %map = reverse @_ctcp_lowlevel_escape;
153     $data =~ s/\020(.)/defined $map{$1} ? $map{$1} : $1/ge;
154     $data
155     }
156    
157     sub escape_lowlevel {
158     my ($data) = @_;
159     my %map = @_ctcp_lowlevel_escape;
160     $data =~ s/([\000\012\015\020])/"\020$map{$1}"/ge;
161     $data
162     }
163    
164     sub unescape_ctcp {
165     my ($data) = @_;
166     $data =~ s/\\(.)/$1 eq 'a' ? "\001" : ($1 eq "\\" ? "\\" : $1)/eg;
167     $data
168     }
169    
170     sub escape_ctcp {
171     my ($data) = @_;
172     $data =~ s/([\\\001])/$1 eq "\001" ? "\\a" : "\\\\"/eg;
173     $data
174     }
175    
176     =item B<decode_ctcp ($trailing)>
177    
178     This function decodes the C<$trailing> part of an IRC message.
179     It will first unescape the lower layer, extract CTCP messages
180     and then return a list with two elements: the line without the ctcp messages
181     and an array reference which contains array references of CTCP messages.
182     Those CTCP message array references will have the CTCP message tag as
183     first element (eg. "VERSION") and the rest of the CTCP message as the second
184     element.
185    
186     =cut
187    
188 elmex 1.1 sub decode_ctcp {
189 elmex 1.6 my ($line) = @_;
190 elmex 1.1
191 elmex 1.12 $line = unescape_lowlevel ($line);
192     my @ctcp;
193 elmex 1.6 while ($line =~ /\G\001([^\001]*)\001/g) {
194 elmex 1.12 my $msg = unescape_ctcp ($1);
195     my ($tag, $data) = split / /, $msg, 2;
196     push @ctcp, [$tag, $data];
197 elmex 1.6 }
198 elmex 1.1
199 elmex 1.6 $line =~ s/\001[^\001]*\001//g;
200 elmex 1.1
201 elmex 1.12 return ($line, \@ctcp)
202     }
203    
204     =item B<encode_ctcp (@msg)>
205    
206     This function encodes a ctcp message for the trailing part of a NOTICE
207     or PRIVMSG. C<@msg> is an array of strings or array references.
208     If an array reference occurs in the C<@msg> array it's first
209     element will be interpreted as CTCP TAG (eg. one of PING, VERSION, .. whatever)
210     the rest of the array ref will be appended to the tag and seperated by
211     spaces.
212    
213     All parts of the message will be contatenated and lowlevel quoted.
214     That means you can embed _any_ character from 0 to 255 in this message (thats
215     what the lowlevel quoting allows).
216    
217     =cut
218    
219     sub encode_ctcp {
220     my (@args) = @_;
221     escape_lowlevel (
222     join "", map {
223     ref $_
224     ? "\001" . escape_ctcp (join " ", @$_) . "\001"
225     : $_
226     } @args
227     )
228 elmex 1.6 }
229 elmex 1.1
230 elmex 1.8 =item B<filter_ctcp_text_attr ($line, $cb)>
231    
232     TODO
233    
234     =cut
235 elmex 1.6 # implemented after the below CTCP spec, but
236     # doesnt seem to be used by anyone... so it's untested.
237     sub filter_ctcp_text_attr {
238     my ($line, $cb) = @_;
239 elmex 1.10 return unless $cb;
240 elmex 1.6 $line =~ s/\006([BVUSI])/{warn "FIL\n"; my $c = $cb->($1); defined $c ? $c : "\006$1"}/ieg;
241     $line =~ s/\006CA((?:I[0-9A-F]|#[0-9A-F]{3}){2})/{my $c = $cb->($1); defined $c ? $c : "\006CA$1"}/ieg;
242     $line =~ s/\006C([FB])(I[0-9A-F]|#[0-9A-F]{3})/{my $c = $cb->($1, $2); defined $c ? $c : "\006C$1$2"}/ieg;
243     $line =~ s/\006CX([AFB])/{my $c = $cb->($1); defined $c ? $c : "\006CX$1"}/ieg;
244     return $line;
245 elmex 1.1 }
246    
247     =item B<split_prefix ($prefix)>
248    
249     This function splits an IRC user prefix as described by RFC 2817
250     into the three parts: nickname, user and host. Which will be
251     returned as a list with that order.
252    
253     C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.
254    
255     =cut
256    
257     sub split_prefix {
258     my ($prfx) = @_;
259    
260     if (ref ($prfx) eq 'HASH') {
261     $prfx = $prfx->{prefix};
262     }
263    
264 elmex 1.11 # this splitting does indeed use the servername as nickname, but there
265     # is no way for a client to distinguish.
266     $prfx =~ m/^\s*([^!]*)(?:!([^@]*))?(?:@(.*?))?\s*$/;
267 elmex 1.1 return ($1, $2, $3);
268     }
269    
270     =item B<prefix_nick ($prefix)>
271    
272     A shortcut to extract the nickname from the C<$prefix>.
273    
274     C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.
275    
276     =cut
277    
278     sub prefix_nick {
279     my ($prfx) = @_;
280     return (split_prefix ($prfx))[0];
281     }
282    
283     =item B<prefix_user ($prefix)>
284    
285     A shortcut to extract the username from the C<$prefix>.
286    
287     C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.
288    
289     =cut
290    
291     sub prefix_user {
292     my ($prfx) = @_;
293     return (split_prefix ($prfx))[1];
294     }
295    
296     =item B<prefix_host ($prefix)>
297    
298     A shortcut to extract the hostname from the C<$prefix>.
299    
300     C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.
301    
302     =cut
303    
304     sub prefix_host {
305 elmex 1.8 my ($prfx) = @_;
306 elmex 1.1 return (split_prefix ($prfx))[2];
307     }
308    
309    
310 elmex 1.7 =item B<rfc_code_to_name ($code)>
311    
312     This function is a interface to the internal mapping or numeric
313     replies to the reply name in RFC 2812 (which you may also consult).
314    
315     C<$code> is returned if no name for C<$code> exists
316     (as some server may extended the protocol).
317    
318 elmex 1.8 =back
319    
320 elmex 1.7 =cut
321    
322     our %RFC_NUMCODE_MAP = (
323     '001' => 'RPL_WELCOME',
324     '002' => 'RPL_YOURHOST',
325     '003' => 'RPL_CREATED',
326     '004' => 'RPL_MYINFO',
327     '005' => 'RPL_BOUNCE',
328     '200' => 'RPL_TRACELINK',
329     '201' => 'RPL_TRACECONNECTING',
330     '202' => 'RPL_TRACEHANDSHAKE',
331     '203' => 'RPL_TRACEUNKNOWN',
332     '204' => 'RPL_TRACEOPERATOR',
333     '205' => 'RPL_TRACEUSER',
334     '206' => 'RPL_TRACESERVER',
335     '207' => 'RPL_TRACESERVICE',
336     '208' => 'RPL_TRACENEWTYPE',
337     '209' => 'RPL_TRACECLASS',
338     '210' => 'RPL_TRACERECONNECT',
339     '211' => 'RPL_STATSLINKINFO',
340     '212' => 'RPL_STATSCOMMANDS',
341     '219' => 'RPL_ENDOFSTATS',
342     '221' => 'RPL_UMODEIS',
343     '233' => 'RPL_SERVICE',
344     '234' => 'RPL_SERVLIST',
345     '235' => 'RPL_SERVLISTEND',
346     '242' => 'RPL_STATSUPTIME',
347     '243' => 'RPL_STATSOLINE',
348     '250' => 'RPL_STATSDLINE',
349     '251' => 'RPL_LUSERCLIENT',
350     '252' => 'RPL_LUSEROP',
351     '253' => 'RPL_LUSERUNKNOWN',
352     '254' => 'RPL_LUSERCHANNELS',
353     '255' => 'RPL_LUSERME',
354     '256' => 'RPL_ADMINME',
355     '257' => 'RPL_ADMINLOC1',
356     '258' => 'RPL_ADMINLOC2',
357     '259' => 'RPL_ADMINEMAIL',
358     '261' => 'RPL_TRACELOG',
359     '262' => 'RPL_TRACEEND',
360     '263' => 'RPL_TRYAGAIN',
361     '301' => 'RPL_AWAY',
362     '302' => 'RPL_USERHOST',
363     '303' => 'RPL_ISON',
364     '305' => 'RPL_UNAWAY',
365     '306' => 'RPL_NOWAWAY',
366     '311' => 'RPL_WHOISUSER',
367     '312' => 'RPL_WHOISSERVER',
368     '313' => 'RPL_WHOISOPERATOR',
369     '314' => 'RPL_WHOWASUSER',
370     '315' => 'RPL_ENDOFWHO',
371     '317' => 'RPL_WHOISIDLE',
372     '318' => 'RPL_ENDOFWHOIS',
373     '319' => 'RPL_WHOISCHANNELS',
374     '321' => 'RPL_LISTSTART',
375     '322' => 'RPL_LIST',
376     '323' => 'RPL_LISTEND',
377     '324' => 'RPL_CHANNELMODEIS',
378     '325' => 'RPL_UNIQOPIS',
379     '331' => 'RPL_NOTOPIC',
380     '332' => 'RPL_TOPIC',
381     '341' => 'RPL_INVITING',
382     '342' => 'RPL_SUMMONING',
383     '346' => 'RPL_INVITELIST',
384     '347' => 'RPL_ENDOFINVITELIST',
385     '348' => 'RPL_EXCEPTLIST',
386     '349' => 'RPL_ENDOFEXCEPTLIST',
387     '351' => 'RPL_VERSION',
388     '352' => 'RPL_WHOREPLY',
389     '353' => 'RPL_NAMREPLY',
390     '364' => 'RPL_LINKS',
391     '365' => 'RPL_ENDOFLINKS',
392     '366' => 'RPL_ENDOFNAMES',
393     '367' => 'RPL_BANLIST',
394     '368' => 'RPL_ENDOFBANLIST',
395     '369' => 'RPL_ENDOFWHOWAS',
396     '371' => 'RPL_INFO',
397     '372' => 'RPL_MOTD',
398     '374' => 'RPL_ENDOFINFO',
399     '375' => 'RPL_MOTDSTART',
400     '376' => 'RPL_ENDOFMOTD',
401     '381' => 'RPL_YOUREOPER',
402     '382' => 'RPL_REHASHING',
403     '383' => 'RPL_YOURESERVICE',
404     '384' => 'RPL_MYPORTIS',
405     '391' => 'RPL_TIME',
406     '392' => 'RPL_USERSSTART',
407     '393' => 'RPL_USERS',
408     '394' => 'RPL_ENDOFUSERS',
409     '395' => 'RPL_NOUSERS',
410     '401' => 'ERR_NOSUCHNICK',
411     '402' => 'ERR_NOSUCHSERVER',
412     '403' => 'ERR_NOSUCHCHANNEL',
413     '404' => 'ERR_CANNOTSENDTOCHAN',
414     '405' => 'ERR_TOOMANYCHANNELS',
415     '406' => 'ERR_WASNOSUCHNICK',
416     '407' => 'ERR_TOOMANYTARGETS',
417     '408' => 'ERR_NOSUCHSERVICE',
418     '409' => 'ERR_NOORIGIN',
419     '411' => 'ERR_NORECIPIENT',
420     '412' => 'ERR_NOTEXTTOSEND',
421     '413' => 'ERR_NOTOPLEVEL',
422     '414' => 'ERR_WILDTOPLEVEL',
423     '415' => 'ERR_BADMASK',
424     '421' => 'ERR_UNKNOWNCOMMAND',
425     '422' => 'ERR_NOMOTD',
426     '423' => 'ERR_NOADMININFO',
427     '424' => 'ERR_FILEERROR',
428     '431' => 'ERR_NONICKNAMEGIVEN',
429     '432' => 'ERR_ERRONEUSNICKNAME',
430     '433' => 'ERR_NICKNAMEINUSE',
431     '436' => 'ERR_NICKCOLLISION',
432     '437' => 'ERR_UNAVAILRESOURCE',
433     '441' => 'ERR_USERNOTINCHANNEL',
434     '442' => 'ERR_NOTONCHANNEL',
435     '443' => 'ERR_USERONCHANNEL',
436     '444' => 'ERR_NOLOGIN',
437     '445' => 'ERR_SUMMONDISABLED',
438     '446' => 'ERR_USERSDISABLED',
439     '451' => 'ERR_NOTREGISTERED',
440     '461' => 'ERR_NEEDMOREPARAMS',
441     '462' => 'ERR_ALREADYREGISTRED',
442     '463' => 'ERR_NOPERMFORHOST',
443     '464' => 'ERR_PASSWDMISMATCH',
444     '465' => 'ERR_YOUREBANNEDCREEP',
445     '466' => 'ERR_YOUWILLBEBANNED',
446     '467' => 'ERR_KEYSET',
447     '471' => 'ERR_CHANNELISFULL',
448     '472' => 'ERR_UNKNOWNMODE',
449     '473' => 'ERR_INVITEONLYCHAN',
450     '474' => 'ERR_BANNEDFROMCHAN',
451     '475' => 'ERR_BADCHANNELKEY',
452     '476' => 'ERR_BADCHANMASK',
453     '477' => 'ERR_NOCHANMODES',
454     '478' => 'ERR_BANLISTFULL',
455     '481' => 'ERR_NOPRIVILEGES',
456     '482' => 'ERR_CHANOPRIVSNEEDED',
457     '483' => 'ERR_CANTKILLSERVER',
458     '484' => 'ERR_RESTRICTED',
459     '485' => 'ERR_UNIQOPPRIVSNEEDED',
460     '491' => 'ERR_NOOPERHOST',
461     '492' => 'ERR_NOSERVICEHOST',
462     '501' => 'ERR_UMODEUNKNOWNFLAG',
463     '502' => 'ERR_USERSDONTMATCH',
464     );
465    
466     sub rfc_code_to_name {
467     my ($code) = @_;
468     return $RFC_NUMCODE_MAP{$code} || $code;
469     }
470    
471 elmex 1.1 =head1 AUTHOR
472    
473     Robin Redeker, C<< <elmex@ta-sa.org> >>
474    
475     =head1 SEE ALSO
476    
477 elmex 1.6 Internet Relay Chat Client To Client Protocol from February 2, 1997
478     http://www.invlogic.com/irc/ctcp.html
479    
480 elmex 1.1 RFC 2812 - Internet Relay Chat: Client Protocol
481    
482     =head1 COPYRIGHT & LICENSE
483    
484 elmex 1.3 Copyright 2006 Robin Redeker, all rights reserved.
485 elmex 1.1
486     This program is free software; you can redistribute it and/or modify it
487     under the same terms as Perl itself.
488    
489     =cut
490    
491     1;