ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Net-IRC3/lib/Net/IRC3/Util.pm
Revision: 1.13
Committed: Sat Aug 18 12:39:02 2007 UTC (17 years, 3 months ago) by elmex
Branch: MAIN
Changes since 1.12: +15 -11 lines
Log Message:
implemented color filtering for irc

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