ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/Net-IRC3/lib/Net/IRC3/Util.pm
Revision: 1.15
Committed: Sat Aug 18 12:59:37 2007 UTC (17 years, 3 months ago) by elmex
Branch: MAIN
CVS Tags: HEAD
Changes since 1.14: +2 -1 lines
Log Message:
filter some more thigns...

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 =~ s/[\x03\x16\x02\x1f\x0f]//g; # see some undefined place :-)
236 $line
237 }
238
239
240 # implemented after the below CTCP spec, but
241 # doesnt seem to be used by anyone... so it's untested.
242 sub filter_ctcp_text_attr_bogus {
243 my ($line, $cb) = @_;
244 return unless $cb;
245 $line =~ s/\006([BVUSI])/{warn "FIL\n"; my $c = $cb->($1); defined $c ? $c : "\006$1"}/ieg;
246 $line =~ s/\006CA((?:I[0-9A-F]|#[0-9A-F]{3}){2})/{my $c = $cb->($1); defined $c ? $c : "\006CA$1"}/ieg;
247 $line =~ s/\006C([FB])(I[0-9A-F]|#[0-9A-F]{3})/{my $c = $cb->($1, $2); defined $c ? $c : "\006C$1$2"}/ieg;
248 $line =~ s/\006CX([AFB])/{my $c = $cb->($1); defined $c ? $c : "\006CX$1"}/ieg;
249 return $line;
250 }
251
252 =item B<split_prefix ($prefix)>
253
254 This function splits an IRC user prefix as described by RFC 2817
255 into the three parts: nickname, user and host. Which will be
256 returned as a list with that order.
257
258 C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.
259
260 =cut
261
262 sub split_prefix {
263 my ($prfx) = @_;
264
265 if (ref ($prfx) eq 'HASH') {
266 $prfx = $prfx->{prefix};
267 }
268
269 # this splitting does indeed use the servername as nickname, but there
270 # is no way for a client to distinguish.
271 $prfx =~ m/^\s*([^!]*)(?:!([^@]*))?(?:@(.*?))?\s*$/;
272 return ($1, $2, $3);
273 }
274
275 =item B<prefix_nick ($prefix)>
276
277 A shortcut to extract the nickname from the C<$prefix>.
278
279 C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.
280
281 =cut
282
283 sub prefix_nick {
284 my ($prfx) = @_;
285 return (split_prefix ($prfx))[0];
286 }
287
288 =item B<prefix_user ($prefix)>
289
290 A shortcut to extract the username from the C<$prefix>.
291
292 C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.
293
294 =cut
295
296 sub prefix_user {
297 my ($prfx) = @_;
298 return (split_prefix ($prfx))[1];
299 }
300
301 =item B<prefix_host ($prefix)>
302
303 A shortcut to extract the hostname from the C<$prefix>.
304
305 C<$prefix> can also be a hash like it is returned by C<parse_irc_msg>.
306
307 =cut
308
309 sub prefix_host {
310 my ($prfx) = @_;
311 return (split_prefix ($prfx))[2];
312 }
313
314
315 =item B<rfc_code_to_name ($code)>
316
317 This function is a interface to the internal mapping or numeric
318 replies to the reply name in RFC 2812 (which you may also consult).
319
320 C<$code> is returned if no name for C<$code> exists
321 (as some server may extended the protocol).
322
323 =back
324
325 =cut
326
327 our %RFC_NUMCODE_MAP = (
328 '001' => 'RPL_WELCOME',
329 '002' => 'RPL_YOURHOST',
330 '003' => 'RPL_CREATED',
331 '004' => 'RPL_MYINFO',
332 '005' => 'RPL_BOUNCE',
333 '200' => 'RPL_TRACELINK',
334 '201' => 'RPL_TRACECONNECTING',
335 '202' => 'RPL_TRACEHANDSHAKE',
336 '203' => 'RPL_TRACEUNKNOWN',
337 '204' => 'RPL_TRACEOPERATOR',
338 '205' => 'RPL_TRACEUSER',
339 '206' => 'RPL_TRACESERVER',
340 '207' => 'RPL_TRACESERVICE',
341 '208' => 'RPL_TRACENEWTYPE',
342 '209' => 'RPL_TRACECLASS',
343 '210' => 'RPL_TRACERECONNECT',
344 '211' => 'RPL_STATSLINKINFO',
345 '212' => 'RPL_STATSCOMMANDS',
346 '219' => 'RPL_ENDOFSTATS',
347 '221' => 'RPL_UMODEIS',
348 '233' => 'RPL_SERVICE',
349 '234' => 'RPL_SERVLIST',
350 '235' => 'RPL_SERVLISTEND',
351 '242' => 'RPL_STATSUPTIME',
352 '243' => 'RPL_STATSOLINE',
353 '250' => 'RPL_STATSDLINE',
354 '251' => 'RPL_LUSERCLIENT',
355 '252' => 'RPL_LUSEROP',
356 '253' => 'RPL_LUSERUNKNOWN',
357 '254' => 'RPL_LUSERCHANNELS',
358 '255' => 'RPL_LUSERME',
359 '256' => 'RPL_ADMINME',
360 '257' => 'RPL_ADMINLOC1',
361 '258' => 'RPL_ADMINLOC2',
362 '259' => 'RPL_ADMINEMAIL',
363 '261' => 'RPL_TRACELOG',
364 '262' => 'RPL_TRACEEND',
365 '263' => 'RPL_TRYAGAIN',
366 '301' => 'RPL_AWAY',
367 '302' => 'RPL_USERHOST',
368 '303' => 'RPL_ISON',
369 '305' => 'RPL_UNAWAY',
370 '306' => 'RPL_NOWAWAY',
371 '311' => 'RPL_WHOISUSER',
372 '312' => 'RPL_WHOISSERVER',
373 '313' => 'RPL_WHOISOPERATOR',
374 '314' => 'RPL_WHOWASUSER',
375 '315' => 'RPL_ENDOFWHO',
376 '317' => 'RPL_WHOISIDLE',
377 '318' => 'RPL_ENDOFWHOIS',
378 '319' => 'RPL_WHOISCHANNELS',
379 '321' => 'RPL_LISTSTART',
380 '322' => 'RPL_LIST',
381 '323' => 'RPL_LISTEND',
382 '324' => 'RPL_CHANNELMODEIS',
383 '325' => 'RPL_UNIQOPIS',
384 '331' => 'RPL_NOTOPIC',
385 '332' => 'RPL_TOPIC',
386 '341' => 'RPL_INVITING',
387 '342' => 'RPL_SUMMONING',
388 '346' => 'RPL_INVITELIST',
389 '347' => 'RPL_ENDOFINVITELIST',
390 '348' => 'RPL_EXCEPTLIST',
391 '349' => 'RPL_ENDOFEXCEPTLIST',
392 '351' => 'RPL_VERSION',
393 '352' => 'RPL_WHOREPLY',
394 '353' => 'RPL_NAMREPLY',
395 '364' => 'RPL_LINKS',
396 '365' => 'RPL_ENDOFLINKS',
397 '366' => 'RPL_ENDOFNAMES',
398 '367' => 'RPL_BANLIST',
399 '368' => 'RPL_ENDOFBANLIST',
400 '369' => 'RPL_ENDOFWHOWAS',
401 '371' => 'RPL_INFO',
402 '372' => 'RPL_MOTD',
403 '374' => 'RPL_ENDOFINFO',
404 '375' => 'RPL_MOTDSTART',
405 '376' => 'RPL_ENDOFMOTD',
406 '381' => 'RPL_YOUREOPER',
407 '382' => 'RPL_REHASHING',
408 '383' => 'RPL_YOURESERVICE',
409 '384' => 'RPL_MYPORTIS',
410 '391' => 'RPL_TIME',
411 '392' => 'RPL_USERSSTART',
412 '393' => 'RPL_USERS',
413 '394' => 'RPL_ENDOFUSERS',
414 '395' => 'RPL_NOUSERS',
415 '401' => 'ERR_NOSUCHNICK',
416 '402' => 'ERR_NOSUCHSERVER',
417 '403' => 'ERR_NOSUCHCHANNEL',
418 '404' => 'ERR_CANNOTSENDTOCHAN',
419 '405' => 'ERR_TOOMANYCHANNELS',
420 '406' => 'ERR_WASNOSUCHNICK',
421 '407' => 'ERR_TOOMANYTARGETS',
422 '408' => 'ERR_NOSUCHSERVICE',
423 '409' => 'ERR_NOORIGIN',
424 '411' => 'ERR_NORECIPIENT',
425 '412' => 'ERR_NOTEXTTOSEND',
426 '413' => 'ERR_NOTOPLEVEL',
427 '414' => 'ERR_WILDTOPLEVEL',
428 '415' => 'ERR_BADMASK',
429 '421' => 'ERR_UNKNOWNCOMMAND',
430 '422' => 'ERR_NOMOTD',
431 '423' => 'ERR_NOADMININFO',
432 '424' => 'ERR_FILEERROR',
433 '431' => 'ERR_NONICKNAMEGIVEN',
434 '432' => 'ERR_ERRONEUSNICKNAME',
435 '433' => 'ERR_NICKNAMEINUSE',
436 '436' => 'ERR_NICKCOLLISION',
437 '437' => 'ERR_UNAVAILRESOURCE',
438 '441' => 'ERR_USERNOTINCHANNEL',
439 '442' => 'ERR_NOTONCHANNEL',
440 '443' => 'ERR_USERONCHANNEL',
441 '444' => 'ERR_NOLOGIN',
442 '445' => 'ERR_SUMMONDISABLED',
443 '446' => 'ERR_USERSDISABLED',
444 '451' => 'ERR_NOTREGISTERED',
445 '461' => 'ERR_NEEDMOREPARAMS',
446 '462' => 'ERR_ALREADYREGISTRED',
447 '463' => 'ERR_NOPERMFORHOST',
448 '464' => 'ERR_PASSWDMISMATCH',
449 '465' => 'ERR_YOUREBANNEDCREEP',
450 '466' => 'ERR_YOUWILLBEBANNED',
451 '467' => 'ERR_KEYSET',
452 '471' => 'ERR_CHANNELISFULL',
453 '472' => 'ERR_UNKNOWNMODE',
454 '473' => 'ERR_INVITEONLYCHAN',
455 '474' => 'ERR_BANNEDFROMCHAN',
456 '475' => 'ERR_BADCHANNELKEY',
457 '476' => 'ERR_BADCHANMASK',
458 '477' => 'ERR_NOCHANMODES',
459 '478' => 'ERR_BANLISTFULL',
460 '481' => 'ERR_NOPRIVILEGES',
461 '482' => 'ERR_CHANOPRIVSNEEDED',
462 '483' => 'ERR_CANTKILLSERVER',
463 '484' => 'ERR_RESTRICTED',
464 '485' => 'ERR_UNIQOPPRIVSNEEDED',
465 '491' => 'ERR_NOOPERHOST',
466 '492' => 'ERR_NOSERVICEHOST',
467 '501' => 'ERR_UMODEUNKNOWNFLAG',
468 '502' => 'ERR_USERSDONTMATCH',
469 );
470
471 sub rfc_code_to_name {
472 my ($code) = @_;
473 return $RFC_NUMCODE_MAP{$code} || $code;
474 }
475
476 =head1 AUTHOR
477
478 Robin Redeker, C<< <elmex@ta-sa.org> >>
479
480 =head1 SEE ALSO
481
482 Internet Relay Chat Client To Client Protocol from February 2, 1997
483 http://www.invlogic.com/irc/ctcp.html
484
485 RFC 2812 - Internet Relay Chat: Client Protocol
486
487 =head1 COPYRIGHT & LICENSE
488
489 Copyright 2006 Robin Redeker, all rights reserved.
490
491 This program is free software; you can redistribute it and/or modify it
492 under the same terms as Perl itself.
493
494 =cut
495
496 1;