File Coverage

blib/lib/Parse/IRC.pm
Criterion Covered Total %
statement 67 110 60.9
branch 22 82 26.8
condition 12 22 54.5
subroutine 9 11 81.8
pod 3 3 100.0
total 113 228 49.5


line stmt bran cond sub pod time code
1             package Parse::IRC;
2             {
3             $Parse::IRC::VERSION = '1.20';
4             }
5              
6             #ABSTRACT: A parser for the IRC protocol.
7              
8             # We export some stuff
9             require Exporter;
10             @ISA = qw[Exporter];
11             @EXPORT = qw[parse_irc];
12              
13 3     3   79838 use strict;
  3         7  
  3         117  
14 3     3   15 use warnings;
  3         7  
  3         107  
15 3     3   18 use File::Basename qw[fileparse];
  3         6  
  3         9384  
16              
17             my $g = {
18             space => qr/\x20+/o,
19             trailing_space => qr/\x20*/o,
20             };
21              
22             my $irc_regex = qr/^
23             (?:
24             \x3a # : comes before hand
25             (\S+) # [prefix]
26             $g->{'space'} # Followed by a space
27             )? # but is optional.
28             (
29             \d{3}|[a-zA-Z]+ # [command]
30             ) # required.
31             (?:
32             $g->{'space'} # Strip leading space off [middle]s
33             ( # [middle]s
34             (?:
35             [^\x00\x0a\x0d\x20\x3a]
36             [^\x00\x0a\x0d\x20]*
37             ) # Match on 1 of these,
38             (?:
39             $g->{'space'}
40             [^\x00\x0a\x0d\x20\x3a]
41             [^\x00\x0a\x0d\x20]*
42             )* # then match on 0-13 of these,
43             )
44             )? # otherwise dont match at all.
45             (?:
46             $g->{'space'}\x3a # Strip off leading spacecolon for [trailing]
47             ([^\x00\x0a\x0d]*) # [trailing]
48             )? # [trailing] is not necessary.
49             $g->{'trailing_space'}
50             $/x;
51              
52             # the magic cookie jar
53             my %dcc_types = (
54             qr/^(?:CHAT|SEND)$/ => sub {
55             my ($nick, $type, $args) = @_;
56             my ($file, $addr, $port, $size);
57             return if !(($file, $addr, $port, $size) = $args =~ /^(".+"|[^ ]+) +(\d+) +(\d+)(?: +(\d+))?/);
58              
59             if ($file =~ s/^"//) {
60             $file =~ s/"$//;
61             $file =~ s/\\"/"/g;
62             }
63             $file = fileparse($file);
64              
65             return (
66             $port,
67             {
68             nick => $nick,
69             type => $type,
70             file => $file,
71             size => $size,
72             addr => $addr,
73             port => $port,
74             },
75             $file,
76             $size,
77             $addr,
78             );
79             },
80             qr/^(?:ACCEPT|RESUME)$/ => sub {
81             my ($nick, $type, $args) = @_;
82             my ($file, $port, $position);
83             return if !(($file, $port, $position) = $args =~ /^(".+"|[^ ]+) +(\d+) +(\d+)/);
84              
85             $file =~ s/^"|"$//g;
86             $file = fileparse($file);
87              
88             return (
89             $port,
90             {
91             nick => $nick,
92             type => $type,
93             file => $file,
94             size => $position,
95             port => $port,
96             },
97             $file,
98             $position,
99             );
100             },
101             );
102              
103             sub parse_irc {
104 2   50 2 1 26 my $string = shift || return;
105 2         18 return __PACKAGE__->new(@_)->parse($string);
106             }
107              
108             sub new {
109 7     7 1 15803 my $package = shift;
110 7         23 my %opts = @_;
111 7         52 $opts{lc $_} = delete $opts{$_} for keys %opts;
112 7         41 return bless \%opts, $package;
113             }
114              
115             sub parse {
116 8     8 1 3641 my $self = shift;
117 8   50     35 my $raw_line = shift || return;
118 8         46 $raw_line =~ s/(\x0D\x0A?|\x0A\x0D?)$//;
119 8 50       145 if ( my($prefix, $command, $middles, $trailing) = $raw_line =~ m/$irc_regex/ ) {
120 8         27 my $event = { raw_line => $raw_line };
121 8 50       38 $event->{'prefix'} = $prefix if $prefix;
122 8         29 $event->{'command'} = uc $command;
123 8 50 33     145 $event->{'params'} = [] if ( defined ( $middles ) || defined ( $trailing ) );
124 8 50       25 push @{$event->{'params'}}, (split /$g->{'space'}/, $middles) if defined ( $middles );
  8         82  
125 8 50       28 push @{$event->{'params'}}, $trailing if defined( $trailing );
  8         22  
126 8 50 66     78 if ( $self->{ctcp} and $event->{'command'} =~ /^(PRIVMSG|NOTICE)$/ and $event->{params}->[1] =~ tr/\001// ) {
      66        
127 2         9 return $self->_get_ctcp( $event );
128             }
129 6 50 66     39 if ( $self->{public} and $event->{'command'} eq 'PRIVMSG' and $event->{'params'}->[0] =~ /^(\x23|\x26)/ ) {
      66        
130 1         2 $event->{'command'} = 'PUBLIC';
131             }
132 6         23 return $event;
133             }
134             else {
135 0 0       0 warn "Received line $raw_line that is not IRC protocol\n" if $self->{debug};
136             }
137 0         0 return;
138             }
139              
140             sub _get_ctcp {
141 2     2   5 my ($self, $line) = @_;
142              
143             # Is this a CTCP request or reply?
144 2 50       9 my $ctcp_type = $line->{command} eq 'PRIVMSG' ? 'CTCP' : 'CTCPREPLY';
145              
146             # CAPAP IDENTIFY-MSG is only applied to ACTIONs
147 2         7 my ($msg, $identified) = ($line->{params}->[1], undef);
148 2 50 33     18 ($msg, $identified) = _split_idmsg($msg) if $self->{identifymsg} && $msg =~ /^.ACTION/;
149              
150 2         4 my $events;
151 2         9 my ($ctcp, $text) = _ctcp_dequote($msg);
152              
153 2 50       6 if (!defined $ctcp) {
154 0 0       0 warn "Received malformed CTCP message: $msg\n" if $self->{debug};
155 0         0 return $events;
156             }
157              
158 2 50       16 my $nick = defined $line->{prefix} ? (split /!/, $line->{prefix})[0] : undef;
159              
160             # We only process the first CTCP. The only people who send multiple ones
161             # are those who are trying to flood our outgoing queue anyway (e.g. by
162             # having us reply to 20 VERSION requests at a time).
163 2         4 my ($name, $args);
164 2         7 CTCP: for my $string ($ctcp->[0]) {
165 2 50       16 if (!(($name, $args) = $string =~ /^(\w+)(?: +(.*))?/)) {
166             defined $nick
167 0 0       0 ? do { warn "Received malformed CTCP message from $nick: $string\n" if $self->{debug} }
168 0 0       0 : do { warn "Trying to send malformed CTCP message: $string\n" if $self->{debug} }
  0 0       0  
169             ;
170 0         0 last CTCP;
171             }
172              
173 2 50       623 if (lc $name eq 'dcc') {
174 0         0 my ($dcc_type, $rest);
175              
176 0 0       0 if (!(($dcc_type, $rest) = $args =~ /^(\w+) +(.+)/)) {
177             defined $nick
178 0 0       0 ? do { warn "Received malformed DCC request from $nick: $args\n" if $self->{debug} }
179 0 0       0 : do { warn "Trying to send malformed DCC request: $args\n" if $self->{debug} }
  0 0       0  
180             ;
181 0         0 last CTCP;
182              
183             }
184 0         0 $dcc_type = uc $dcc_type;
185              
186 0         0 my ($handler) = grep { $dcc_type =~ /$_/ } keys %dcc_types;
  0         0  
187 0 0       0 if (!$handler) {
188 0 0       0 warn "Unhandled DCC $dcc_type request: $rest\n" if $self->{debug};
189 0         0 last CTCP;
190             }
191              
192 0         0 my @dcc_args = $dcc_types{$handler}->($nick, $dcc_type, $rest);
193 0 0       0 if (!@dcc_args) {
194             defined $nick
195 0 0       0 ? do { warn "Received malformed DCC $dcc_type request from $nick: $rest\n" if $self->{debug} }
196 0 0       0 : do { warn "Trying to send malformed DCC $dcc_type request: $rest\n" if $self->{debug} }
  0 0       0  
197             ;
198 0         0 last CTCP;
199             }
200              
201             $events = {
202 0         0 prefix => $line->{prefix},
203             command => 'DCC_REQUEST',
204             params => [
205             $dcc_type,
206             @dcc_args,
207             ],
208             raw_line => $line->{raw_line},
209             };
210             }
211             else {
212 2 50       31 $events = {
    50          
213             command => $ctcp_type . '_' . uc $name,
214             prefix => $line->{prefix},
215             params => [
216             $line->{params}->[0],
217             (defined $args ? $args : ''),
218             (defined $identified ? $identified : () ),
219             ],
220             raw_line => $line->{raw_line},
221             };
222             }
223             }
224              
225             # XXX: I'm not quite sure what this is for, but on FreeNode it adds an
226             # extra bogus event and displays a debug message, so I have disabled it.
227             # FreeNode precedes PRIVMSG and CTCP ACTION messages with '+' or '-'.
228             #if ($text && @$text) {
229             # my $what;
230             # ($what) = $line->{raw_line} =~ /^(:[^ ]+ +\w+ +[^ ]+ +)/
231             # or warn "What the heck? '".$line->{raw_line}."'\n" if $self->{debug};
232             # $text = (defined $what ? $what : '') . ':' . join '', @$text;
233             # $text =~ s/\cP/^P/g;
234             # warn "CTCP: $text\n" if $self->{debug};
235             # push @$events, @{ $self->{_ircd}->get([$text]) };
236             #}
237              
238 2         17 return $events;
239             }
240              
241             sub _split_idmsg {
242 0     0   0 my ($line) = @_;
243 0         0 my ($identified, $msg) = split //, $line, 2;
244 0 0       0 $identified = $identified eq '+' ? 1 : 0;
245 0         0 return $msg, $identified;
246             }
247              
248             # Splits a message into CTCP and text chunks. This is gross. Most of
249             # this is also stolen from Net::IRC, but I (fimm) wrote that too, so it's
250             # used with permission. ;-)
251             sub _ctcp_dequote {
252 2     2   5 my ($msg) = @_;
253 2         4 my (@chunks, $ctcp, $text);
254              
255             # CHUNG! CHUNG! CHUNG!
256              
257 2 50       6 if (!defined $msg) {
258 0         0 die 'Not enough arguments to Parse::IRC::_ctcp_dequote';
259             }
260              
261             # Strip out any low-level quoting in the text.
262 2         8 $msg = _low_dequote( $msg );
263              
264             # Filter misplaced \001s before processing... (Thanks, tchrist!)
265 2 50       10 substr($msg, rindex($msg, "\001"), 1, '\\a')
266             if ($msg =~ tr/\001//) % 2 != 0;
267              
268 2 50       7 return if $msg !~ tr/\001//;
269              
270 2         10 @chunks = split /\001/, $msg;
271 2 50       8 shift @chunks if !length $chunks[0]; # FIXME: Is this safe?
272              
273 2         8 for (@chunks) {
274             # Dequote unnecessarily quoted chars, and convert escaped \'s and ^A's.
275 2         27 s/\\([^\\a])/$1/g;
276 2         5 s/\\\\/\\/g;
277 2         8 s/\\a/\001/g;
278             }
279              
280             # If the line begins with a control-A, the first chunk is a CTCP
281             # message. Otherwise, it starts with text and alternates with CTCP
282             # messages. Really stupid protocol.
283 2 50       12 if ($msg =~ /^\001/) {
284 2         6 push @$ctcp, shift @chunks;
285             }
286              
287 2         8 while (@chunks) {
288 0         0 push @$text, shift @chunks;
289 0 0       0 push @$ctcp, shift @chunks if @chunks;
290             }
291              
292 2         7 return ($ctcp, $text);
293             }
294              
295             # Quotes a string in a low-level, protocol-safe, utterly brain-dead
296             # fashion. Returns the quoted string.
297             sub _low_quote {
298 0     0   0 my ($line) = @_;
299 0         0 my %enquote = ("\012" => 'n', "\015" => 'r', "\0" => '0', "\cP" => "\cP");
300              
301 0 0       0 if (!defined $line) {
302 0         0 die 'Not enough arguments to Parse::IRC->_low_quote';
303             }
304              
305 0 0       0 if ($line =~ tr/[\012\015\0\cP]//) { # quote \n, \r, ^P, and \0.
306 0         0 $line =~ s/([\012\015\0\cP])/\cP$enquote{$1}/g;
307             }
308              
309 0         0 return $line;
310             }
311              
312             # Does low-level dequoting on CTCP messages. I hate this protocol.
313             # Yes, I copied this whole section out of Net::IRC.
314             sub _low_dequote {
315 2     2   4 my ($line) = @_;
316 2         16 my %dequote = (n => "\012", r => "\015", 0 => "\0", "\cP" => "\cP");
317              
318 2 50       8 if (!defined $line) {
319 0         0 die 'Not enough arguments to Parse::IRC->_low_dequote';
320             }
321              
322             # dequote \n, \r, ^P, and \0.
323             # Thanks to Abigail (abigail@foad.org) for this clever bit.
324 2 50       8 if ($line =~ tr/\cP//) {
325 0         0 $line =~ s/\cP([nr0\cP])/$dequote{$1}/g;
326             }
327              
328 2         7 return $line;
329             }
330              
331             q[Operation Blackbriar];
332              
333             __END__