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
|
|
|
|
|
[] |
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
|
|
|
|
|
|
150
|
|
|
|
|
|
151
|
|
|
|
|
|
152
|
|
|
|
|
|
153
|
|
|
|
|
|
154
|
37
|
100
|
|
|
if ( substr($raw_line, 0, 1) eq '@' ) { |
155
|
17
|
50
|
|
|
return unless (my $nextsp = index($raw_line, SPCHR)) > 0; |
156
|
|
|
|
|
|
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
|
|
|
|
|
|
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
|
|
|
|
|
|