File Coverage

blib/lib/Protocol/IRC/Client.pm
Criterion Covered Total %
statement 14 159 8.8
branch 0 60 0.0
condition 0 9 0.0
subroutine 5 20 25.0
pod 2 14 14.2
total 21 262 8.0


line stmt bran cond sub pod time code
1             # You may distribute under the terms of either the GNU General Public License
2             # or the Artistic License (the same terms as Perl itself)
3             #
4             # (C) Paul Evans, 2010-2015 -- leonerd@leonerd.org.uk
5              
6             package Protocol::IRC::Client;
7              
8 1     1   1066 use strict;
  1         2  
  1         25  
9 1     1   5 use warnings;
  1         1  
  1         24  
10 1     1   27 use 5.010; # //
  1         3  
11 1     1   4 use base qw( Protocol::IRC );
  1         2  
  1         97  
12              
13             our $VERSION = '0.11';
14              
15 1     1   5 use Carp;
  1         1  
  1         2693  
16              
17             =head1 NAME
18              
19             C - IRC protocol handling for a client
20              
21             =head1 DESCRIPTION
22              
23             This mix-in class provides a layer of IRC message handling logic suitable for
24             an IRC client. It builds upon L to provide extra message
25             processing useful to IRC clients, such as handling inbound server numerics.
26              
27             It provides some of the methods required by C:
28              
29             =over 4
30              
31             =item * isupport
32              
33             =back
34              
35             =cut
36              
37             =head1 METHODS
38              
39             =cut
40              
41             =head2 isupport
42              
43             $value = $irc->isupport( $key )
44              
45             Returns an item of information from the server's C<005 ISUPPORT> lines.
46             Traditionally IRC servers use all-capital names for keys.
47              
48             =cut
49              
50             # A few hardcoded defaults from RFC 2812
51             my %ISUPPORT = (
52             channame_re => qr/^[#&]/,
53             prefixflag_re => qr/^[\@+]/,
54             chanmodes_list => [qw( b k l imnpst )], # TODO: ov
55             );
56              
57             sub isupport
58             {
59 0     0 1   my $self = shift;
60 0           my ( $field ) = @_;
61 0   0       return $self->{Protocol_IRC_isupport}->{$field} // $ISUPPORT{$field};
62             }
63              
64             sub on_message_RPL_ISUPPORT
65             {
66 0     0 0   my $self = shift;
67 0           my ( $message, $hints ) = @_;
68              
69 0   0       my $isupport = $self->{Protocol_IRC_isupport} ||= {};
70              
71 0           foreach my $entry ( @{ $hints->{isupport} } ) {
  0            
72 0           my ( $name, $value ) = $entry =~ m/^([A-Z]+)(?:=(.*))?$/;
73              
74 0 0         $value = 1 if !defined $value;
75              
76 0           $isupport->{$name} = $value;
77              
78 0 0         if( $name eq "PREFIX" ) {
    0          
    0          
    0          
79 0           my $prefix = $value;
80              
81 0 0         my ( $prefix_modes, $prefix_flags ) = $prefix =~ m/^\(([a-z]+)\)(.+)$/i
82             or warn( "Unable to parse PREFIX=$value" ), next;
83              
84 0           $isupport->{prefix_modes} = $prefix_modes;
85 0           $isupport->{prefix_flags} = $prefix_flags;
86              
87 0           $isupport->{prefixflag_re} = qr/[$prefix_flags]/;
88              
89 0           my %prefix_map;
90 0           $prefix_map{substr $prefix_modes, $_, 1} = substr $prefix_flags, $_, 1 for ( 0 .. length($prefix_modes) - 1 );
91              
92 0           $isupport->{prefix_map_m2f} = \%prefix_map;
93 0           $isupport->{prefix_map_f2m} = { reverse %prefix_map };
94             }
95             elsif( $name eq "CHANMODES" ) {
96 0           $isupport->{chanmodes_list} = [ split( m/,/, $value ) ];
97             }
98             elsif( $name eq "CASEMAPPING" ) {
99             # TODO
100             # $self->{nick_folded} = $self->casefold_name( $self->{nick} );
101             }
102             elsif( $name eq "CHANTYPES" ) {
103 0           $isupport->{channame_re} = qr/^[$value]/;
104             }
105             }
106              
107 0           return 0;
108             }
109              
110             =head2 server_info
111              
112             $info = $irc->server_info( $key )
113              
114             Returns an item of information from the server's C<004> line. C<$key> should
115             one of
116              
117             =over 8
118              
119             =item * host
120              
121             =item * version
122              
123             =item * usermodes
124              
125             =item * channelmodes
126              
127             =back
128              
129             =cut
130              
131             sub server_info
132             {
133 0     0 1   my $self = shift;
134 0           my ( $key ) = @_;
135              
136 0           return $self->{Protocol_IRC_server_info}{$key};
137             }
138              
139             sub on_message_RPL_MYINFO
140             {
141 0     0 0   my $self = shift;
142 0           my ( $message, $hints ) = @_;
143              
144 0           @{$self->{Protocol_IRC_server_info}}{qw( host version usermodes channelmodes )} =
145 0           @{$hints}{qw( serverhost serverversion usermodes channelmodes )};
  0            
146              
147 0           return 0;
148             }
149              
150             =head1 GATING MESSAGES
151              
152             If messages with a gating disposition are received, extra processing is
153             applied. Messages whose gating effect is C are simply collected up by
154             pushing the hints hash to an array. Added to this hash is the command name
155             itself, so that in the case of multiple message types (for example C
156             replies) the individual messages can still be identified.
157              
158             When the effect of C or C is eventually received, this collected
159             array is passed as C<$data> to a handler in one of the following places:
160              
161             =over 4
162              
163             =item 1.
164              
165             A method called C
166              
167             $client->on_gate_EFFECT_GATE( $message, $hints, $data )
168              
169             =item 2.
170              
171             A method called C
172              
173             $client->on_gate_EFFECT( 'GATE', $message, $hints, $data )
174              
175             =item 3.
176              
177             A method called C
178              
179             $client->on_gate( 'EFFECT, 'GATE', $message, $hints, $data )
180              
181             =back
182              
183             =cut
184              
185             sub on_message_gate
186             {
187 0     0 0   my $self = shift;
188 0           my ( $effect, $gate, $message, $hints ) = @_;
189 0   0       my $target = $hints->{target_name_folded} // "*";
190              
191 0 0         if( $effect eq "more" ) {
192 0           push @{ $self->{Protocol_IRC_gate}{$target}{$gate} }, {
  0            
193             %$hints,
194             command => $message->command_name,
195             };
196 0           return 1;
197             }
198              
199 0           my $data = delete $self->{Protocol_IRC_gate}{$target}{$gate};
200 0 0         keys %{ $self->{Protocol_IRC_gate}{$target} } or delete $self->{Protocol_IRC_gate}{$target};
  0            
201              
202 0           my %hints = (
203             %$hints,
204             synthesized => 1,
205             );
206              
207 0 0         $self->invoke( "on_gate_${effect}_$gate", $message, \%hints, $data ) and $hints{handled} = 1;
208 0 0         $self->invoke( "on_gate_$effect", $gate, $message, \%hints, $data ) and $hints{handled} = 1;
209 0 0         $self->invoke( "on_gate", $effect, $gate, $message, \%hints, $data ) and $hints{handled} = 1;
210              
211 0           return $hints{handled};
212             }
213              
214             =head1 INTERNAL MESSAGE HANDLING
215              
216             The following messages are handled internally by C.
217              
218             =cut
219              
220             sub _invoke_synthetic
221             {
222 0     0     my $self = shift;
223 0           my ( $command, $message, $hints, @morehints ) = @_;
224              
225 0           my %hints = (
226             %$hints,
227             synthesized => 1,
228             @morehints,
229             );
230 0           delete $hints{handled};
231              
232 0 0         $self->invoke( "on_message_$command", $message, \%hints ) and $hints{handled} = 1;
233 0 0         $self->invoke( "on_message", $command, $message, \%hints ) and $hints{handled} = 1;
234              
235 0           return $hints{handled};
236             }
237              
238             =head2 CAP
239              
240             This message takes a sub-verb as its second argument, and a list of capability
241             names as its third. On receipt of a C message, the verb is extracted and
242             set as the C hint, and the list capabilities set as the keys of a hash
243             given as the C hint. These are then passed to an event called
244              
245             $irc->on_message_cap_VERB( $message, \%hints )
246              
247             or
248              
249             $irc->on_message_cap( 'VERB', $message, \%hints )
250              
251             =cut
252              
253             sub on_message_CAP
254             {
255 0     0 0   my $self = shift;
256 0           my ( $message, $hints ) = @_;
257              
258 0           my $verb = $message->arg(1);
259              
260             my %hints = (
261             %$hints,
262             verb => $verb,
263 0           caps => { map { $_ => 1 } split m/ /, $message->arg(2) },
  0            
264             );
265              
266 0 0         $self->invoke( "on_message_cap_$verb", $message, \%hints ) and $hints{handled} = 1;
267 0 0         $self->invoke( "on_message_cap", $verb, $message, \%hints ) and $hints{handled} = 1;
268              
269 0           return $hints{handled};
270             }
271              
272             =head2 MODE (on channels) and 324 (RPL_CHANNELMODEIS)
273              
274             These messages involve channel modes. The raw list of channel modes is parsed
275             into an array containing one entry per affected piece of data. Each entry will
276             contain at least a C key, indicating what sort of mode or mode change
277             it is:
278              
279             =over 8
280              
281             =item list
282              
283             The mode relates to a list; bans, invites, etc..
284              
285             =item value
286              
287             The mode sets a value about the channel
288              
289             =item bool
290              
291             The mode is a simple boolean flag about the channel
292              
293             =item occupant
294              
295             The mode relates to a user in the channel
296              
297             =back
298              
299             Every mode type then provides a C key, containing the mode character
300             itself, and a C key which is an empty string, C<+>, or C<->.
301              
302             For C and C types, the C key gives the actual list entry
303             or value being set.
304              
305             For C types, a C key gives the mode converted into an occupant
306             flag (by the C method), C and C store the
307             user name affected.
308              
309             C types do not create any extra keys.
310              
311             =cut
312              
313             sub prepare_hints_channelmode
314             {
315 0     0 0   my $self = shift;
316 0           my ( $message, $hints ) = @_;
317              
318 0           my ( $listmodes, $argmodes, $argsetmodes, $boolmodes ) = @{ $self->isupport( 'chanmodes_list' ) };
  0            
319              
320 0           my $modechars = $hints->{modechars};
321 0           my @modeargs = @{ $hints->{modeargs} };
  0            
322              
323 0           my @modes; # [] -> { type => $, sense => $, mode => $, arg => $ }
324              
325 0           my $sense = 0;
326 0           foreach my $modechar ( split( m//, $modechars ) ) {
327 0 0         $sense = 1, next if $modechar eq "+";
328 0 0         $sense = -1, next if $modechar eq "-";
329              
330 0           my $hasarg;
331              
332 0           my $mode = {
333             mode => $modechar,
334             sense => $sense,
335             };
336              
337 0 0         if( index( $listmodes, $modechar ) > -1 ) {
    0          
    0          
    0          
    0          
338 0           $mode->{type} = 'list';
339 0 0         $mode->{value} = shift @modeargs if ( $sense != 0 );
340             }
341             elsif( index( $argmodes, $modechar ) > -1 ) {
342 0           $mode->{type} = 'value';
343 0 0         $mode->{value} = shift @modeargs if ( $sense != 0 );
344             }
345             elsif( index( $argsetmodes, $modechar ) > -1 ) {
346 0           $mode->{type} = 'value';
347 0 0         $mode->{value} = shift @modeargs if ( $sense > 0 );
348             }
349             elsif( index( $boolmodes, $modechar ) > -1 ) {
350 0           $mode->{type} = 'bool';
351             }
352             elsif( my $flag = $self->prefix_mode2flag( $modechar ) ) {
353 0           $mode->{type} = 'occupant';
354 0           $mode->{flag} = $flag;
355 0 0         $mode->{nick} = shift @modeargs if ( $sense != 0 );
356 0           $mode->{nick_folded} = $self->casefold_name( $mode->{nick} );
357             }
358             else {
359             # TODO: Err... not recognised ... what do I do?
360             }
361              
362             # TODO: Consider a per-mode event here...
363              
364 0           push @modes, $mode;
365             }
366              
367 0           $hints->{modes} = \@modes;
368             }
369              
370             sub prepare_hints_MODE
371             {
372 0     0 0   my $self = shift;
373 0           my ( $message, $hints ) = @_;
374              
375 0 0         if( $hints->{target_type} eq "channel" ) {
376 0           $self->prepare_hints_channelmode( $message, $hints );
377             }
378             }
379              
380             sub prepare_hints_RPL_CHANNELMODEIS
381             {
382 0     0 0   my $self = shift;
383 0           my ( $message, $hints ) = @_;
384              
385 0           $self->prepare_hints_channelmode( $message, $hints );
386             }
387              
388             =head2 RPL_WHOREPLY and RPL_ENDOFWHO
389              
390             These messages will be collected up, per channel, by the message gating
391             system, and formed into a single synthesized event called C.
392              
393             Its hints hash will contain an extra key, C, which will be an ARRAY ref
394             containing the lines of the WHO reply. Each line will be a HASH reference
395             containing:
396              
397             =over 8
398              
399             =item user_ident
400              
401             =item user_host
402              
403             =item user_server
404              
405             =item user_nick
406              
407             =item user_nick_folded
408              
409             =item user_flags
410              
411             =back
412              
413             =cut
414              
415             sub on_gate_done_who
416             {
417 0     0 0   my $self = shift;
418 0           my ( $message, $hints, $data ) = @_;
419              
420             my @who = map {
421 0           my $b = $_;
  0            
422 0           +{ map { $_ => $b->{$_} } qw( user_ident user_host user_server user_nick user_nick_folded user_flags ) }
  0            
423             } @$data;
424              
425 0           $self->_invoke_synthetic( "who", $message, $hints,
426             who => \@who,
427             );
428             }
429              
430             =head2 RPL_NAMEREPLY and RPL_ENDOFNAMES
431              
432             These messages will be collected up, per channel, by the message gating
433             system, and formed into a single synthesized event called C.
434              
435             Its hints hash will contain an extra key, C, which will be an ARRAY ref
436             containing the usernames in the channel. Each will be a HASH reference
437             containing:
438              
439             =over 8
440              
441             =item nick
442              
443             =item flag
444              
445             =back
446              
447             =cut
448              
449             sub on_gate_done_names
450             {
451 0     0 0   my $self = shift;
452 0           my ( $message, $hints, $data ) = @_;
453              
454 0           my @names = map { @{ $_->{names} } } @$data;
  0            
  0            
455              
456 0           my $prefixflag_re = $self->isupport( 'prefixflag_re' );
457 0           my $re = qr/^($prefixflag_re)?(.*)$/;
458              
459 0           my %names;
460              
461 0           foreach my $name ( @names ) {
462 0 0         my ( $flag, $nick ) = $name =~ $re or next;
463              
464 0   0       $flag ||= ''; # make sure it's defined
465              
466 0           $names{ $self->casefold_name( $nick ) } = { nick => $nick, flag => $flag };
467             }
468              
469 0           $self->_invoke_synthetic( "names", $message, $hints,
470             names => \%names,
471             );
472             }
473              
474             =head2 RPL_BANLIST and RPL_ENDOFBANS
475              
476             These messages will be collected up, per channel, by the message gating
477             system, and formed into a single synthesized event called C.
478              
479             Its hints hash will contain an extra key, C, which will be an ARRAY ref
480             containing the ban lines. Each line will be a HASH reference containing:
481              
482             =over 8
483              
484             =item mask
485              
486             User mask of the ban
487              
488             =item by_nick
489              
490             =item by_nick_folded
491              
492             Nickname of the user who set the ban
493              
494             =item timestamp
495              
496             UNIX timestamp the ban was created
497              
498             =back
499              
500             =cut
501              
502             sub on_gate_done_bans
503             {
504 0     0 0   my $self = shift;
505 0           my ( $message, $hints, $data ) = @_;
506              
507             my @bans = map {
508 0           my $b = $_;
  0            
509 0           +{ map { $_ => $b->{$_} } qw( mask by_nick by_nick_folded timestamp ) }
  0            
510             } @$data;
511              
512 0           $self->_invoke_synthetic( "bans", $message, $hints,
513             bans => \@bans,
514             );
515             }
516              
517             =head2 RPL_MOTD, RPL_MOTDSTART and RPL_ENDOFMOTD
518              
519             These messages will be collected up, by the message gating system, into a
520             synthesized event called C.
521              
522             Its hints hash will contain an extra key, C, which will be an ARRAY ref
523             containing the lines of the MOTD.
524              
525             =cut
526              
527             sub on_gate_done_motd
528             {
529 0     0 0   my $self = shift;
530 0           my ( $message, $hints, $data ) = @_;
531              
532             $self->_invoke_synthetic( "motd", $message, $hints,
533 0           motd => [ map { $_->{text} } @$data ],
  0            
534             );
535             }
536              
537             =head2 RPL_WHOIS* and RPL_ENDOFWHOIS
538              
539             These messages will be collected up, by the message gating system, into a
540             synthesized event called C.
541              
542             Each C reply will be stripped of the standard hints hash keys,
543             leaving whatever remains. Added to this will be a key called C, whose
544             value will be the command name, minus the leading C, and converted
545             to lowercase.
546              
547             =cut
548              
549             sub on_gate_done_whois
550             {
551 0     0 0   my $self = shift;
552 0           my ( $message, $hints, $data ) = @_;
553              
554 0           my @whois;
555             my $channels;
556              
557 0           foreach my $h ( @$data ) {
558             # Just delete all the standard hints from each one
559 0           delete @{$h}{keys %$hints};
  0            
560 0           ( $h->{whois} = lc delete $h->{command} ) =~ s/^rpl_whois//;
561              
562             # Combine all the 'channels' results into one list
563 0 0         if( $h->{whois} eq "channels" ) {
564 0 0         if( $channels ) {
565 0           push @{$channels->{channels}}, @{$h->{channels}};
  0            
  0            
566 0           next;
567             }
568 0           $channels = $h;
569             }
570              
571 0           push @whois, $h;
572             }
573              
574 0           $self->_invoke_synthetic( "whois", $message, $hints, whois => \@whois );
575             }
576              
577             =head1 AUTHOR
578              
579             Paul Evans
580              
581             =cut
582              
583             0x55AA;