File Coverage

lib/POE/Filter/IRCv3.pm
Criterion Covered Total %
statement 121 127 95.3
branch 40 54 74.1
condition 12 16 75.0
subroutine 16 17 94.1
total 189 214 88.3


line stmt bran cond sub code
1         package POE::Filter::IRCv3;
2 1     1 use strict; use warnings FATAL => 'all';
  1     1  
  1        
  1        
  1        
  1        
3 1     1 use Carp;
  1        
  1        
4          
5         BEGIN {
6 1 50   1   if (eval { require POE::Filter; 1 }) {
  1        
  1        
7 1           our @ISA = 'POE::Filter';
8           }
9         }
10          
11         =pod
12        
13         =for Pod::Coverage COLONIFY DEBUG BUFFER SPCHR
14        
15         =cut
16          
17         sub COLONIFY () { 0 }
18         sub DEBUG () { 1 }
19         sub BUFFER () { 2 }
20         sub SPCHR () { "\x20" }
21          
22         sub new {
23 3     3   my ($class, %params) = @_;
24 3         map {; $params{uc $_} = $params{$_} } keys %params;
  3        
25 3   100     bless [
      50    
26             ($params{'COLONIFY'} || 0),
27             ($params{'DEBUG'} || $ENV{POE_FILTER_IRC_DEBUG} || 0),
28             [] ## BUFFER
29           ], $class
30         }
31          
32         sub clone {
33 1     1   my ($self) = @_;
34 1         my $nself = [@$self];
35 1         $nself->[BUFFER] = [];
36 1         bless $nself, ref $self
37         }
38          
39         sub debug {
40 0     0   my ($self, $value) = @_;
41 0 0       return $self->[DEBUG] = $value if defined $value;
42 0         $self->[DEBUG]
43         }
44          
45         sub colonify {
46 2     2   my ($self, $value) = @_;
47 2 100       return $self->[COLONIFY] = $value if defined $value;
48 1         $self->[COLONIFY]
49         }
50          
51          
52         sub get_one_start {
53 2     2   my ($self, $raw_lines) = @_;
54 2         push @{ $self->[BUFFER] }, $_ for @$raw_lines;
  2        
55         }
56          
57         sub get_pending {
58 1     1   my ($self) = @_;
59 1 50       @{ $self->[BUFFER] } ? [ @{ $self->[BUFFER] } ] : ()
  1        
  1        
60         }
61          
62         sub get {
63 35     35   my @events;
64 35         for my $raw_line (@{ $_[1] }) {
  35        
65 35 50         warn " >> '$raw_line'\n" if $_[0]->[DEBUG];
66 35 100         if ( my $event = _parseline($raw_line) ) {
67 32             push @events, $event;
68             } else {
69 3             carp "Received malformed IRC input: $raw_line";
70             }
71           }
72           \@events
73 35       }
74          
75         sub get_one {
76 2     2   my ($self) = @_;
77 2         my @events;
78 2 50       if ( my $raw_line = shift @{ $self->[BUFFER] } ) {
  2        
79 2 50         warn " >> '$raw_line'\n" if $self->[DEBUG];
80 2 50         if ( my $event = _parseline($raw_line) ) {
81 2             push @events, $event;
82             } else {
83 0             warn "Received malformed IRC input: $raw_line\n";
84             }
85           }
86           \@events
87 2       }
88          
89          
90 1     1 use bytes;
  1        
  1        
91          
92          
93         sub put {
94 19     19   my ($self, $events) = @_;
95 19         my $raw_lines = [];
96          
97 19         for my $event (@$events) {
98          
99 19 50         if ( ref $event eq 'HASH' ) {
100 19             my $raw_line;
101          
102 19 100 66         if ( $event->{tags} && (my @tags = %{ $event->{tags} }) ) {
  2        
103 2                 $raw_line .= '@';
104 2                 while (my ($thistag, $thisval) = splice @tags, 0, 2) {
105 6 100                 $raw_line .= $thistag . ( defined $thisval ? '='.$thisval : '' );
106 6 100                 $raw_line .= ';' if @tags;
107                   }
108 2                 $raw_line .= ' ';
109               }
110          
111 19 100           $raw_line .= ':' . $event->{prefix} . ' ' if $event->{prefix};
112 19             $raw_line .= $event->{command};
113          
114 19 100 66         if ( $event->{params} && (my @params = @{ $event->{params} }) ) {
  17        
115 17                 $raw_line .= ' ';
116 17                 my $param = shift @params;
117 17                 while (@params) {
118 14                   $raw_line .= $param . ' ';
119 14                   $param = shift @params;
120                   }
121 17 100 66             $raw_line .= ':'
    100      
122                     if (index($param, SPCHR) != -1)
123                     or (
124                       defined $event->{colonify} ?
125                       $event->{colonify} : $self->[COLONIFY]
126                     );
127 17                 $raw_line .= $param;
128               }
129          
130 19             push @$raw_lines, $raw_line;
131 19 50           warn " << '$raw_line'\n" if $self->[DEBUG];
132             } else {
133 0             carp "($self) non-HASH passed to put(): '$event'";
134 0 0           push @$raw_lines, $event if ref $event eq 'SCALAR';
135             }
136          
137           }
138          
139           $raw_lines
140 19       }
141          
142          
143         sub _parseline {
144 37     37   my $raw_line = $_[0];
145 37         my %event = ( raw_line => $raw_line );
146 37         my $pos = 0;
147 1     1   no warnings 'substr';
  1        
  1        
148          
149         ## We cheat a little; the spec is fuzzy when it comes to CR, LF, and NUL
150         ## bytes. Theoretically they're not allowed inside messages, but
151         ## that's really an implementation detail (and the spec agrees).
152         ## We just stick to SPCHR (\x20) here.
153          
154 37 100       if ( substr($raw_line, 0, 1) eq '@' ) {
155 17 50         return unless (my $nextsp = index($raw_line, SPCHR)) > 0;
156         # Tag parser cheats; split takes a pattern:
157 17           for my $tag_pair
158               ( split /;/, substr $raw_line, 1, ($nextsp - 1) ) {
159 37                 my ($thistag, $thisval) = split /=/, $tag_pair;
160 37                 $event{tags}->{$thistag} = $thisval
161             }
162 17           $pos = $nextsp + 1;
163           }
164          
165 37         $pos++ while substr($raw_line, $pos, 1) eq SPCHR;
166          
167 37 100       if ( substr($raw_line, $pos, 1) eq ':' ) {
168 25           my $nextsp;
169 25 100 100       ($nextsp = index $raw_line, SPCHR, $pos) > 0 and length(
170                 $event{prefix} = substr $raw_line, ($pos + 1), ($nextsp - $pos - 1)
171             ) or return;
172 22           $pos = $nextsp + 1;
173 22           $pos++ while substr($raw_line, $pos, 1) eq SPCHR;
174           }
175          
176 34         my $nextsp_maybe;
177 34 100       if ( ($nextsp_maybe = index $raw_line, SPCHR, $pos) == -1 ) {
178         # No more spaces; do we have anything..?
179 3           my $cmd = substr $raw_line, $pos;
180 3 50         $event{command} = uc( length $cmd ? $cmd : return );
181 3           return \%event
182           }
183          
184           $event{command} = uc(
185 31           substr($raw_line, $pos, ($nextsp_maybe - $pos) )
186           );
187 31         $pos = $nextsp_maybe + 1;
188          
189 31         $pos++ while substr($raw_line, $pos, 1) eq SPCHR;
190          
191 31         my $maxlen = length $raw_line;
192 31         PARAM: while ( $pos < $maxlen ) {
193 54 100         if ( substr($raw_line, $pos, 1) eq ':' ) {
194 21             push @{ $event{params} }, substr $raw_line, ($pos + 1);
  21        
195               last PARAM
196 21           }
197 33 100         if ( (my $nextsp = index $raw_line, SPCHR, $pos) == -1 ) {
198 9             push @{ $event{params} }, substr $raw_line, $pos;
  9        
199               last PARAM
200 9           } else {
201 24             push @{ $event{params} }, substr $raw_line, $pos, ($nextsp - $pos);
  24        
202 24             $pos = $nextsp + 1;
203 24             $pos++ while substr($raw_line, $pos, 1) eq SPCHR;
204               next PARAM
205 24           }
206           }
207          
208 31         \%event
209         }
210          
211          
212 1     1 no bytes;
  1        
  1        
213          
214          
215         print
216           qq[<mst> let's try this again -without- the part where we beat you to],
217           qq[ death with a six foot plush toy of sexual harassment panda\n ]
218         unless caller; 1;
219          
220          
221         =pod
222        
223         =head1 NAME
224        
225         POE::Filter::IRCv3 - IRCv3.2 parser without regular expressions
226        
227         =head1 SYNOPSIS
228        
229         my $filter = POE::Filter::IRCv3->new(colonify => 1);
230        
231         # Raw lines parsed to hashes:
232         my $array_of_refs = $filter->get(
233         [
234         ':prefix COMMAND foo :bar',
235         '@foo=bar;baz :prefix COMMAND foo :bar',
236         ]
237         );
238        
239         # Hashes deparsed to raw lines:
240         my $array_of_lines = $filter->put(
241         [
242         {
243         prefix => 'prefix',
244         command => 'COMMAND',
245         params => [
246         'foo',
247         'bar'
248         ],
249         },
250         {
251         prefix => 'prefix',
252         command => 'COMMAND',
253         params => [
254         'foo',
255         'bar'
256         ],
257         tags => {
258         foo => 'bar',
259         baz => undef,
260         },
261         },
262         ]
263         );
264        
265        
266         # Stacked with a line filter, suitable for Wheel usage, etc:
267         my $ircd = POE::Filter::IRCv3->new(colonify => 1);
268         my $line = POE::Filter::Line->new(
269         InputRegexp => '\015?\012',
270         OutputLiteral => "\015\012",
271         );
272         my $stacked = POE::Filter::Stackable->new(
273         Filters => [ $line, $ircd ],
274         );
275        
276         =head1 DESCRIPTION
277        
278         A L<POE::Filter> for IRC traffic with support for IRCv3.2 message tags.
279        
280         Does not rely on regular expressions for parsing, unlike many of its
281         counterparts; benchmarks show this approach is slightly faster on most strings.
282        
283         Like any proper L<POE::Filter>, there are no POE-specific bits involved here
284         -- the filter can be used stand-alone to parse lines of IRC traffic (also see
285         L<IRC::Toolkit::Parser>).
286        
287         In fact, you do not need L<POE> installed -- if L<POE::Filter> is not
288         available, it is left out of C<@ISA> and the filter will continue working
289         normally.
290        
291         =head2 new
292        
293         Construct a new Filter; if the B<colonify> option is true,
294         the last parameter will always have a colon prepended.
295         (This setting can also be retrieved or changed on-the-fly by calling
296         B<colonify> as a method, or changed for specific events by passing a
297         B<colonify> option via events passed to L</put>.)
298        
299         =head2 get_one_start, get_one, get_pending
300        
301         Implement the interface described in L<POE::Filter>.
302        
303         See L</get>.
304        
305         =head2 get
306        
307         my $events = $filter->get( [ $line, $another, ... ] );
308         for my $event (@$events) {
309         my $cmd = $event->{command};
310         ## See below for other keys available
311         }
312        
313         Takes an ARRAY of raw lines and returns an ARRAY of HASH-type references with
314         the following keys:
315        
316         =head3 command
317        
318         The (uppercased) command or numeric.
319        
320         =head3 params
321        
322         An ARRAY containing the event parameters.
323        
324         =head3 prefix
325        
326         The sender prefix, if any.
327        
328         =head3 tags
329        
330         A HASH of key => value pairs matching IRCv3.2 "message tags" -- see
331         L<http://ircv3.atheme.org>.
332        
333         Note that a tag can be present, but have an undefined value.
334        
335         =head2 put
336        
337         my $lines = $filter->put( [ $hash, $another_hash, ... ] );
338         for my $line (@$lines) {
339         ## Direct to socket, etc
340         }
341        
342         Takes an ARRAY of HASH-type references matching those described in L</get>
343         (documented above) and returns an ARRAY of raw IRC-formatted lines.
344        
345         =head3 colonify
346        
347         In addition to the keys described in L</get>, the B<colonify> option can be
348         specified for specific events. This controls whether or not the last
349         parameter will be colon-prefixed even if it is a single word. (Yes, IRC is
350         woefully inconsistent ...)
351        
352         Specify as part of the event hash:
353        
354         $filter->put([ { %event, colonify => 1 } ]);
355        
356         =head2 clone
357        
358         Copy the filter object (with a cleared buffer).
359        
360         =head2 debug
361        
362         Turn on/off debug output, which will display every input/output line (and
363         possibly other data in the future).
364        
365         This is enabled by default at construction time if the environment variable
366         C<POE_FILTER_IRC_DEBUG> is a true value.
367        
368         =head1 AUTHOR
369        
370         Jon Portnoy <avenj@cobaltirc.org>
371        
372         Licensed under the same terms as Perl.
373        
374         Original implementations were derived from L<POE::Filter::IRCD>,
375         which is copyright Chris Williams and Jonathan Steinert. This codebase has
376         diverged significantly.
377        
378         Major thanks to the C<#ircv3> crew on irc.atheme.org, especially C<Aerdan> and
379         C<grawity>, for various bits of inspiration.
380        
381         =head1 SEE ALSO
382        
383         L<IRC::Message::Object>
384        
385         L<POE::Filter>
386        
387         L<POE::Filter::IRCD>
388        
389         L<POE::Filter::Line>
390        
391         L<POE::Filter::Stackable>
392        
393         L<IRC::Toolkit>
394        
395         =cut
396