File Coverage

blib/lib/Net/Async/IRC/Protocol.pm
Criterion Covered Total %
statement 99 108 91.6
branch 27 34 79.4
condition 2 6 33.3
subroutine 23 24 95.8
pod 10 11 90.9
total 161 183 87.9


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-2021 -- leonerd@leonerd.org.uk
5              
6             package Net::Async::IRC::Protocol 0.12;
7              
8 8     8   108 use v5.14;
  8         29  
9 8     8   41 use warnings;
  8         14  
  8         248  
10              
11 8     8   77 use base qw( IO::Async::Stream Protocol::IRC );
  8         51  
  8         5325  
12              
13 8     8   175650 use Carp;
  8         21  
  8         513  
14              
15 8     8   59 use Protocol::IRC::Message;
  8         20  
  8         188  
16              
17 8     8   46 use Encode qw( find_encoding );
  8         19  
  8         367  
18 8     8   52 use Time::HiRes qw( time );
  8         19  
  8         78  
19              
20 8     8   5381 use IO::Async::Timer::Countdown;
  8         14757  
  8         10130  
21              
22             =head1 NAME
23              
24             C - send and receive IRC messages
25              
26             =head1 DESCRIPTION
27              
28             This subclass of L implements an established IRC
29             connection that has already completed its inital login sequence and is ready
30             to send and receive IRC messages. It handles base message sending and
31             receiving, and implements ping timers. This class provides most of the
32             functionality required for sending and receiving IRC commands and responses
33             by mixing in from L.
34              
35             Objects of this type would not normally be constructed directly. For IRC
36             clients, see L which is a subclass of it. All the events,
37             parameters, and methods documented below are relevant there.
38              
39             =cut
40              
41             =head1 EVENTS
42              
43             The following events are invoked, either using subclass methods or C
44             references in parameters:
45              
46             =head2 $handled = on_message
47              
48             =head2 $handled = on_message_MESSAGE
49              
50             Invoked on receipt of a valid IRC message. See C below.
51              
52             =head2 on_irc_error $err
53              
54             Invoked on receipt of an invalid IRC message if parsing fails. C<$err> is the
55             error message text. If left unhandled, any parse error will result in the
56             connection being immediataely closed, followed by the exception being
57             re-thrown.
58              
59             =head2 on_ping_timeout
60              
61             Invoked if the peer fails to respond to a C message within the given
62             timeout.
63              
64             =head2 on_pong_reply $lag
65              
66             Invoked when the peer successfully sends a C reply response to a C
67             message. C<$lag> is the response time in (fractional) seconds.
68              
69             =cut
70              
71             =head1 PARAMETERS
72              
73             The following named parameters may be passed to C or C:
74              
75             =over 8
76              
77             =item on_message => CODE
78              
79             =item on_message_MESSAGE => CODE
80              
81             =item on_irc_error => CODE
82              
83             =item on_ping_timeout => CODE
84              
85             =item on_pong_reply => CODE
86              
87             C references for event handlers.
88              
89             =item pingtime => NUM
90              
91             Amount of quiet time, in seconds, after a message is received from the peer,
92             until a C will be sent to check it is still alive.
93              
94             =item pongtime => NUM
95              
96             Timeout, in seconds, after sending a C message, to wait for a C
97             response.
98              
99             =item encoding => STRING
100              
101             If supplied, sets an encoding to use to encode outgoing messages and decode
102             incoming messages.
103              
104             =back
105              
106             =cut
107              
108             =head1 CONSTRUCTOR
109              
110             =cut
111              
112             =head2 new
113              
114             $irc = Net::Async::IRC::Protocol->new( %args );
115              
116             Returns a new instance of a C object. This object
117             represents a IRC connection to a peer.
118              
119             =cut
120              
121             sub new
122             {
123 9     9 1 27 my $class = shift;
124 9         41 my %args = @_;
125              
126 9         44 my $on_closed = delete $args{on_closed};
127              
128             return $class->SUPER::new(
129             %args,
130              
131             on_closed => sub {
132 0     0   0 my $self = shift;
133              
134 0         0 my $loop = $self->get_loop;
135              
136 0         0 $self->{pingtimer}->stop;
137 0         0 $self->{pongtimer}->stop;
138              
139 0 0       0 $on_closed->( $self ) if $on_closed;
140              
141 0         0 undef $self->{connect_f};
142 0         0 undef $self->{login_f};
143             },
144 9         161 );
145             }
146              
147             sub _init
148             {
149 9     9   21 my $self = shift;
150 9         63 $self->SUPER::_init( @_ );
151              
152 9         312 my $pingtime = 60;
153 9         20 my $pongtime = 10;
154              
155             $self->{pingtimer} = IO::Async::Timer::Countdown->new(
156             delay => $pingtime,
157              
158             on_expire => sub {
159 2     2   4002313 my $now = time();
160              
161 2         213 $self->send_message( "PING", undef, "$now" );
162              
163 2         1065 $self->{ping_send_time} = $now;
164              
165 2         16 $self->{pongtimer}->start;
166             },
167 9         144 );
168 9         1068 $self->add_child( $self->{pingtimer} );
169              
170             $self->{pongtimer} = IO::Async::Timer::Countdown->new(
171             delay => $pongtime,
172              
173             on_expire => sub {
174 1 50   1   1001703 $self->{on_ping_timeout}->( $self ) if $self->{on_ping_timeout};
175             },
176 9         340 );
177 9         561 $self->add_child( $self->{pongtimer} );
178             }
179              
180             # for Protocol::IRC
181             sub encoder
182             {
183 42     42 1 8593 my $self = shift;
184 42         106 return $self->{encoder};
185             }
186              
187             sub configure
188             {
189 11     11 1 25 my $self = shift;
190 11         34 my %args = @_;
191              
192 11         89 $self->{$_} = delete $args{$_} for grep m/^on_message/, keys %args;
193              
194 11         36 for (qw( on_ping_timeout on_pong_reply on_irc_error )) {
195 33 100       92 $self->{$_} = delete $args{$_} if exists $args{$_};
196             }
197              
198 11 100       43 if( exists $args{pingtime} ) {
199 1         5 $self->{pingtimer}->configure( delay => delete $args{pingtime} );
200             }
201              
202 11 100       82 if( exists $args{pongtime} ) {
203 1         4 $self->{pongtimer}->configure( delay => delete $args{pongtime} );
204             }
205              
206 11 100       92 if( exists $args{encoding} ) {
207 1         5 my $encoding = delete $args{encoding};
208 1         6 my $obj = find_encoding( $encoding );
209 1 50       199 defined $obj or croak "Cannot handle an encoding of '$encoding'";
210 1         3 $self->{encoder} = $obj;
211             }
212              
213 11         120 $self->SUPER::configure( %args );
214             }
215              
216             sub incoming_message
217             {
218 20     20 1 1722 my $self = shift;
219 20         42 my ( $message ) = @_;
220              
221 20         70 my @shortargs = ( $message->arg( 0 ) );
222 20 100       213 push @shortargs, $message->arg( 1 ) if $message->command =~ m/^\d+$/;
223 20 100       266 push @shortargs, "..." if $message->args > 1;
224              
225 20         177 $self->debug_printf( "COMMAND ${\ $message->command } @shortargs" );
  20         57  
226              
227 20         325 return $self->SUPER::incoming_message( @_ );
228             }
229              
230             =head1 METHODS
231              
232             =cut
233              
234             =head2 is_connected
235              
236             $connect = $irc->is_connected;
237              
238             Returns true if a connection to the peer is established. Note that even
239             after a successful connection, the connection may not yet logged in to. See
240             also the C method.
241              
242             =cut
243              
244             sub is_connected
245             {
246 6     6 1 1702 my $self = shift;
247 6 100       26 return 0 unless my $connect_f = $self->{connect_f};
248 5   33     18 return $connect_f->is_ready && !$connect_f->failure;
249             }
250              
251             =head2 is_loggedin
252              
253             $loggedin = $irc->is_loggedin;
254              
255             Returns true if the full login sequence has been performed on the connection
256             and it is ready to use.
257              
258             =cut
259              
260             sub is_loggedin
261             {
262 2     2 1 726 my $self = shift;
263 2 100       13 return 0 unless my $login_f = $self->{login_f};
264 1   33     5 return $login_f->is_ready && !$login_f->failure;
265             }
266              
267             sub on_read
268             {
269 21     21 1 2053642 my $self = shift;
270 21         59 my ( $buffref, $eof ) = @_;
271              
272 21         47 my $pingtimer = $self->{pingtimer};
273              
274 21 100       80 $pingtimer->is_running ? $pingtimer->reset : $pingtimer->start;
275              
276 21 100       4789 eval {
277 21         111 $self->Protocol::IRC::on_read( $$buffref );
278 20         393 1;
279             } and return 0;
280              
281 1         442 my $e = "$@"; chomp $e;
  1         6  
282              
283 1 50       4 $self->maybe_invoke_event( on_irc_error => $e )
284             and return 0;
285              
286 0         0 $self->close_now;
287 0         0 die "$e\n";
288             }
289              
290             =head2 nick
291              
292             $nick = $irc->nick;
293              
294             Returns the current nick in use by the connection.
295              
296             =cut
297              
298             sub _set_nick
299             {
300 13     13   30 my $self = shift;
301 13         36 ( $self->{nick} ) = @_;
302 13         65 $self->{nick_folded} = $self->casefold_name( $self->{nick} );
303             }
304              
305             sub nick
306             {
307 4     4 1 1064 my $self = shift;
308 4         21 return $self->{nick};
309             }
310              
311             =head2 nick_folded
312              
313             $nick_folded = $irc->nick_folded;
314              
315             Returns the current nick in use by the connection, folded by C
316             for convenience.
317              
318             =cut
319              
320             sub nick_folded
321             {
322 11     11 1 672 my $self = shift;
323 11         47 return $self->{nick_folded};
324             }
325              
326             =head1 MESSAGE HANDLING
327              
328             Every incoming message causes a sequence of message handling to occur. First,
329             the message is parsed, and a hash of data about it is created; this is called
330             the hints hash. The message and this hash are then passed down a sequence of
331             potential handlers.
332              
333             Each handler indicates by return value, whether it considers the message to
334             have been handled. Processing of the message is not interrupted the first time
335             a handler declares to have handled a message. Instead, the hints hash is
336             marked to say it has been handled. Later handlers can still inspect the
337             message or its hints, using this information to decide if they wish to take
338             further action.
339              
340             A message with a command of C will try handlers in following places:
341              
342             =over 4
343              
344             =item 1.
345              
346             A CODE ref in a parameter called C
347              
348             $on_message_COMMAND->( $irc, $message, \%hints )
349              
350             =item 2.
351              
352             A method called C
353              
354             $irc->on_message_COMMAND( $message, \%hints )
355              
356             =item 3.
357              
358             A CODE ref in a parameter called C
359              
360             $on_message->( $irc, 'COMMAND', $message, \%hints )
361              
362             =item 4.
363              
364             A method called C
365              
366             $irc->on_message( 'COMMAND', $message, \%hints )
367              
368             =back
369              
370             As this message handling ability is provided by C, more details
371             about how it works and how to use it can be found at
372             L.
373              
374             Additionally, some types of messages receive further processing by
375             C and in turn cause new types of events to be invoked. These
376             are further documented by L.
377              
378             =cut
379              
380             sub invoke
381             {
382 60     60 1 2684 my $self = shift;
383 60 100       155 my $retref = $self->maybe_invoke_event( @_ ) or return undef;
384 31         684 return $retref->[0];
385             }
386              
387             sub on_message_PONG
388             {
389 1     1 0 23 my $self = shift;
390 1         3 my ( $message, $hints ) = @_;
391              
392 1 50       5 return 1 unless $self->{pongtimer}->is_running;
393              
394 1         13 my $lag = time - $self->{ping_send_time};
395              
396 1         7 $self->{current_lag} = $lag;
397 1 50       9 $self->{on_pong_reply}->( $self, $lag ) if $self->{on_pong_reply};
398              
399 1         11 $self->{pongtimer}->stop;
400              
401 1         168 return 1;
402             }
403              
404             =head1 AUTHOR
405              
406             Paul Evans
407              
408             =cut
409              
410             0x55AA;