File Coverage

blib/lib/Net/Async/IRC/Protocol.pm

Criterion	Covered	Total	%
statement	88	110	80.0
branch	21	34	61.7
condition	2	12	16.6
subroutine	22	25	88.0
pod	9	12	75.0
total	142	193	73.5

#  You may distribute under the terms of either the GNU General Public License
#  or the Artistic License (the same terms as Perl itself)
#
#  (C) Paul Evans, 2010-2014 -- [e-mail]

package Net::Async::IRC::Protocol;

use strict;
use warnings;

our $VERSION = '0.10';

use base qw( IO::Async::Stream Protocol::IRC );

use Carp;

use Protocol::IRC::Message;

use Encode qw( find_encoding );
use Time::HiRes qw( time );

use IO::Async::Timer::Countdown;

=head1 NAME

C - send and receive IRC messages

=head1 DESCRIPTION

This subclass of L implements an established
IRC connection that has already completed its inital login sequence and is
ready to send and receive IRC messages. It handles base message sending and
receiving, and implements ping timers.

Objects of this type would not normally be constructed directly. For IRC
clients, see L which is a subclass of it. All the events,
parameters, and methods documented below are relevant there.

=cut

=head1 EVENTS

The following events are invoked, either using subclass methods or C
references in parameters:

=head2 $handled = on_message

=head2 $handled = on_message_MESSAGE

Invoked on receipt of a valid IRC message. See C below.

=head2 on_irc_error $err

Invoked on receipt of an invalid IRC message if parsing fails. C<$err> is the
error message text. If left unhandled, any parse error will result in the
connection being immediataely closed, followed by the exception being
re-thrown.

=head2 on_ping_timeout

Invoked if the peer fails to respond to a C message within the given
timeout.

=head2 on_pong_reply $lag

Invoked when the peer successfully sends a C reply response to a C
message. C<$lag> is the response time in (fractional) seconds.

=cut

=head1 PARAMETERS

The following named parameters may be passed to C or C:

=over 8

=item on_message => CODE

=item on_message_MESSAGE => CODE

=item on_irc_error => CODE

=item on_ping_timeout => CODE

=item on_pong_reply => CODE

C references for event handlers.

=item pingtime => NUM

Amount of quiet time, in seconds, after a message is received from the peer,
until a C will be sent to check it is still alive.

=item pongtime => NUM

Timeout, in seconds, after sending a C message, to wait for a C
response.

=item encoding => STRING

If supplied, sets an encoding to use to encode outgoing messages and decode
incoming messages.

=back

=cut

=head1 CONSTRUCTOR

=cut

=head2 $irc = Net::Async::IRC::Protocol->new( %args )

Returns a new instance of a C object. This object
represents a IRC connection to a peer. As it is a subclass of
C its constructor takes any arguments for
that class, in addition to the parameters named below.

=cut

sub new
{
   my $class = shift;
   my %args = @_;

   my $on_closed = delete $args{on_closed};

   return $class->SUPER::new(
      %args,

      on_closed => sub {
         my $self = shift;

         my $loop = $self->get_loop;

         $self->{pingtimer}->stop;
         $self->{pongtimer}->stop;

         $on_closed->( $self ) if $on_closed;

         undef $self->{connect_f};
         undef $self->{login_f};
      },
   );
}

sub _init
{
   my $self = shift;
   $self->SUPER::_init( @_ );

   my $pingtime = 60;
   my $pongtime = 10;

   $self->{pingtimer} = IO::Async::Timer::Countdown->new(
      delay => $pingtime,

      on_expire => sub {
         my $now = time();

         $self->send_message( "PING", undef, "$now" );

         $self->{ping_send_time} = $now;

         $self->{pongtimer}->start;
      },
   );
   $self->add_child( $self->{pingtimer} );

   $self->{pongtimer} = IO::Async::Timer::Countdown->new(
      delay => $pongtime,

      on_expire => sub {
         $self->{on_ping_timeout}->( $self ) if $self->{on_ping_timeout};
      },
   );
   $self->add_child( $self->{pongtimer} );
}

# for Protocol::IRC
sub encoder
{
   my $self = shift;
   return $self->{encoder};
}

sub configure
{
   my $self = shift;
   my %args = @_;

   $self->{$_} = delete $args{$_} for grep m/^on_message/, keys %args;

   for (qw( on_ping_timeout on_pong_reply on_irc_error )) {
      $self->{$_} = delete $args{$_} if exists $args{$_};
   }

   if( exists $args{pingtime} ) {
      $self->{pingtimer}->configure( delay => delete $args{pingtime} );
   }

   if( exists $args{pongtime} ) {
      $self->{pongtimer}->configure( delay => delete $args{pongtime} );
   }

   if( exists $args{encoding} ) {
      my $encoding = delete $args{encoding};
      my $obj = find_encoding( $encoding );
      defined $obj or croak "Cannot handle an encoding of '$encoding'";
      $self->{encoder} = $obj;
   }

   $self->SUPER::configure( %args );
}

sub setup_transport
{
   my $self = shift;
   $self->SUPER::setup_transport( @_ );

   $self->{connect_f} = Future->new->done( $self->transport->read_handle );
   $self->{pingtimer}->start if $self->{pingtimer} and $self->get_loop;
}

sub teardown_transport
{
   my $self = shift;

   undef $self->{connect_f};
   undef $self->{login_f};
   $self->{pingtimer}->stop if $self->{pingtimer} and $self->get_loop;

   $self->SUPER::teardown_transport( @_ );
}

=head1 METHODS

=cut

=head2 $connect = $irc->is_connected

Returns true if a connection to the peer is established. Note that even
after a successful connection, the connection may not yet logged in to. See
also the C method.

=cut

sub is_connected
{
   my $self = shift;
   return 0 unless my $connect_f = $self->{connect_f};
   return $connect_f->is_ready && !$connect_f->failure;
}

=head2 $loggedin = $irc->is_loggedin

Returns true if the full login sequence has been performed on the connection
and it is ready to use.

=cut

sub is_loggedin
{
   my $self = shift;
   return 0 unless my $login_f = $self->{login_f};
   return $login_f->is_ready && !$login_f->failure;
}

sub on_read
{
   my $self = shift;
   my ( $buffref, $eof ) = @_;

   my $pingtimer = $self->{pingtimer};

   $pingtimer->is_running ? $pingtimer->reset : $pingtimer->start;

   eval {
      $self->Protocol::IRC::on_read( $$buffref );
      1;
   } and return 0;

   my $e = "$@"; chomp $e;

   $self->maybe_invoke_event( on_irc_error => $e )
      and return 0;

   $self->close_now;
   die "$e\n";
}

=head2 $nick = $irc->nick

Returns the current nick in use by the connection.

=cut

sub _set_nick
{
   my $self = shift;
   ( $self->{nick} ) = @_;
   $self->{nick_folded} = $self->casefold_name( $self->{nick} );
}

sub nick
{
   my $self = shift;
   return $self->{nick};
}

=head2 $nick_folded = $irc->nick_folded

Returns the current nick in use by the connection, folded by C
for convenience.

=cut

sub nick_folded
{
   my $self = shift;
   return $self->{nick_folded};
}

=head1 MESSAGE HANDLING

A message with a command of C will try handlers in following places:

=over 4

=item 1.

A CODE ref in a parameter called C

 $on_message_COMMAND->( $irc, $message, \%hints )

=item 2.

A method called C

 $irc->on_message_COMMAND( $message, \%hints )

=item 3.

A CODE ref in a parameter called C

 $on_message->( $irc, 'COMMAND', $message, \%hints )

=item 4.

A method called C

 $irc->on_message( 'COMMAND', $message, \%hints )

=back

Certain commands are handled internally by methods on the base
C class itself. These may cause other hints hash
keys to be created, or to invoke other handler methods. These are documented
below.

=cut

sub invoke
{
   my $self = shift;
   my $retref = $self->maybe_invoke_event( @_ ) or return undef;
   return $retref->[0];
}

sub on_message_PONG
{
   my $self = shift;
   my ( $message, $hints ) = @_;

   return 1 unless $self->{pongtimer}->is_running;

   my $lag = time - $self->{ping_send_time};

   $self->{current_lag} = $lag;
   $self->{on_pong_reply}->( $self, $lag ) if $self->{on_pong_reply};

   $self->{pongtimer}->stop;

   return 1;
}

=head1 AUTHOR

Paul Evans

=cut

0x55AA;