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

# 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 encode_ctcp filter_ctcp_text_attr prefix_user prefix_host
9 rfc_code_to_name filter_colors);
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 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 sub decode_ctcp {
182 my ($line) = @_;
183
184 $line = unescape_lowlevel ($line);
185 my @ctcp;
186 while ($line =~ /\G\001([^\001]*)\001/g) {
187 my $msg = unescape_ctcp ($1);
188 my ($tag, $data) = split / /, $msg, 2;
189 push @ctcp, [$tag, $data];
190 }
191
192 $line =~ s/\001[^\001]*\001//g;
193
194 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 }
222
223 =item B<filter_colors ($line)>
224
225 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
229 =cut
230
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 # implemented after the below CTCP spec, but
240 # doesnt seem to be used by anyone... so it's untested.
241 sub filter_ctcp_text_attr_bogus {
242 my ($line, $cb) = @_;
243 return unless $cb;
244 $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 }
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 # 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 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 my ($prfx) = @_;
310 return (split_prefix ($prfx))[2];
311 }
312
313
314 =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 =back
323
324 =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 =head1 AUTHOR
476
477 Robin Redeker, C<< <elmex@ta-sa.org> >>
478
479 =head1 SEE ALSO
480
481 Internet Relay Chat Client To Client Protocol from February 2, 1997
482 http://www.invlogic.com/irc/ctcp.html
483
484 RFC 2812 - Internet Relay Chat: Client Protocol
485
486 =head1 COPYRIGHT & LICENSE
487
488 Copyright 2006 Robin Redeker, all rights reserved.
489
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;