File Coverage

blib/lib/Net/Async/IRC.pm

Criterion	Covered	Total	%
statement	163	187	87.1
branch	28	48	58.3
condition	24	48	50.0
subroutine	29	35	82.8
pod	9	15	60.0
total	253	333	75.9

#  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, 2008-2021 -- [e-mail]

package Net::Async::IRC 0.12;

use v5.14;
use warnings;

# We need to use C3 MRO to make the ->isupport etc.. methods work properly
use mro 'c3';
use base qw( Net::Async::IRC::Protocol Protocol::IRC::Client );

use Future::AsyncAwait;

use Carp;

use List::Util 1.33 qw( any );
use Socket qw( SOCK_STREAM );

use MIME::Base64 qw( encode_base64 decode_base64 );

use constant HAVE_MSWIN32 => ( $^O eq "MSWin32" );

=head1 NAME

C - use IRC with C

=head1 SYNOPSIS

   use Future::AsyncAwait;

   use IO::Async::Loop;
   use Net::Async::IRC;

   my $loop = IO::Async::Loop->new;

   my $irc = Net::Async::IRC->new(
      on_message_text => sub {
         my ( $self, $message, $hints ) = @_;

         print "$hints->{prefix_name} says: $hints->{text}\n";
      },
   );

   $loop->add( $irc );

   await $irc->login(
      nick => "MyName",
      host => "irc.example.org",
   );

   await $irc->do_PRIVMSG( target => "YourName", text => "Hello world!" );

   $loop->run;

=head1 DESCRIPTION

This object class implements an asynchronous IRC client, for use in programs
based on L.

Most of the actual IRC message handling behaviour is implemented by the parent
class L.

Most of the behaviour related to being an IRC client is implemented by the
parent class L.

The following documentation may make mention of these above two parent
classes; the reader should make reference to them when required.

=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;

         if( $self->{on_login_f} ) {
            $_->fail( "Closed" ) for @{ $self->{on_login_f} };
            undef $self->{on_login_f};
         }

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

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

   $self->{user} = $ENV{LOGNAME} ||
      ( HAVE_MSWIN32 ? Win32::LoginName() : getpwuid($>) );

   our $VERSION;
   $self->{realname} = "Net::Async::IRC client $VERSION";
}

=head1 PARAMETERS

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

=over 8

=item nick => STRING

=item user => STRING

=item realname => STRING

Connection details. See also C, C.

If C is not supplied, it will default to either C<$ENV{LOGNAME}> or the
current user's name as supplied by C or C.

If unconnected, changing these properties will set the default values to use
when logging in.

If logged in, changing the C property is equivalent to calling
C. Changing the other properties will not take effect until the
next login.

=item use_caps => ARRAY of STRING

Attempts to negotiate IRC v3.1 CAP at connect time. The array gives the names
of capabilities which will be requested, if the server supports them.

If the C capability is requested and supported by the server, the
C method will use that.

=back

=cut

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

   for (qw( user realname use_caps )) {
      $self->{$_} = delete $args{$_} if exists $args{$_};
   }

   if( exists $args{nick} ) {
      $self->_set_nick( delete $args{nick} );
   }

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

=head1 METHODS

The following methods documented in an C expression return L
instances.

=cut

=head2 connect

   $irc = await $irc->connect( %args );

Connects to the IRC server. This method does not perform the complete IRC
login sequence; for that see instead the C method. The returned
L will yield the C<$irc> instance itself, to make chaining easier.

=over 8

=item host => STRING

Hostname of the IRC server.

=item service => STRING or NUMBER

Optional. Port number or service name of the IRC server. Defaults to 6667.

=back

Any other arguments are passed into the underlying C
C method.

   $irc->connect( %args );

The following additional arguments are used to provide continuations when not
returning a Future.

=over 8

=item on_connected => CODE

Continuation to invoke once the connection has been established. Usually used
by the C method to perform the actual login sequence.

   $on_connected->( $irc )

=item on_error => CODE

Continuation to invoke in the case of an error preventing the connection from
taking place.

   $on_error->( $errormsg )

=back

=cut

# TODO: Most of this needs to be moved into an abstract Net::Async::Connection role
sub connect
{
   my $self = shift;
   my %args = @_;

   # Largely for unit testing
   return $self->{connect_f} ||= Future->new->done( $self ) if
      $self->read_handle;

   my $on_error = delete $args{on_error};

   $args{service} ||= "6667";

   return $self->{connect_f} ||= $self->SUPER::connect(
      %args,

      on_resolve_error => sub {
         my ( $msg ) = @_;
         chomp $msg;

         if( $args{on_resolve_error} ) {
            $args{on_resolve_error}->( $msg );
         }
         elsif( $on_error ) {
            $on_error->( "Cannot resolve - $msg" );
         }
      },

      on_connect_error => sub {
         if( $args{on_connect_error} ) {
            $args{on_connect_error}->( @_ );
         }
         elsif( $on_error ) {
            $on_error->( "Cannot connect" );
         }
      },
   )->on_fail( sub { undef $self->{connect_f} } );
}

=head2 login

   $irc = await $irc->login( %args );

Logs in to the IRC network, connecting first using the C method if
required. Takes the following named arguments:

=over 8

=item nick => STRING

=item user => STRING

=item realname => STRING

IRC connection details. Defaults can be set with the C or C
methods.

=item pass => STRING

Server password to connect with.

=back

Any other arguments that are passed, are forwarded to the C method if
it is required; i.e. if C is invoked when not yet connected to the
server.

   $irc->login( %args );

The following additional arguments are used to provide continuations when not
returning a Future.

=over 8

=item on_login => CODE

A continuation to invoke once login is successful.

   $on_login->( $irc )

=back

If the C capability was requested and is supported by the server, this
will be used instead of the simple C command combination.

At the current version, only the C SASL mechanism is supported.

=cut

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

   return $self->{login_f} //= $self->_login( %args )
      ->on_fail( sub { undef $self->{login_f} } );
}

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

   my $nick     = delete $args{nick} || $self->{nick} or croak "Need a login nick";
   my $user     = delete $args{user} || $self->{user} or croak "Need a login user";
   my $realname = delete $args{realname} || $self->{realname};
   my $pass     = delete $args{pass};

   if( !defined $self->{nick} ) {
      $self->_set_nick( $nick );
   }

   my $on_login = delete $args{on_login};
   !defined $on_login or ref $on_login eq "CODE" or
      croak "Expected 'on_login' to be a CODE reference";

   await $self->connect( %args );

   undef $self->{defer_cap_end_f};
   undef $self->{on_cap_finished_f};

   $self->send_message( "CAP", undef, "LS" ) if $self->{use_caps};

   $self->send_message( "NICK", undef, $nick );

   my $use_sasl;

   if( $self->{use_caps} and any { $_ eq "sasl" } @{ $self->{use_caps} } ) {
      await ( $self->{on_cap_finished_f} //= $self->loop->new_future );

      $use_sasl = $self->cap_supported( "sasl" );
   }

   if( $use_sasl ) {
      push @{ $self->{defer_cap_end_f} }, my $f = $self->loop->new_future;
      undef $self->{on_sasl_complete_f};

      $self->send_message( "USER", undef, $user, "0", "*", $realname );

      # TODO: configurable mechanisms
      $self->send_message( "AUTHENTICATE", undef, "PLAIN" );
      await ( $self->{on_authenticate_f} //= $self->loop->new_future );

      my $payload = encode_base64( join( "\0", $nick, $nick, $pass ), "" );
      $self->send_message( "AUTHENTICATE", undef, $payload );

      await ( $self->{on_sasl_complete_f} //= $self->loop->new_future );

      $f->done;
   }
   else {
      $self->send_message( "PASS", undef, $pass ) if defined $pass;
      $self->send_message( "USER", undef, $user, "0", "*", $realname );
   }

   my $f = $self->loop->new_future;

   push @{ $self->{on_login_f} }, $f;
   $f->on_done( $on_login ) if $on_login;

   return await $f;
}

=head2 change_nick

   $irc->change_nick( $newnick );

Requests to change the nick. If unconnected, the change happens immediately
to the stored defaults. If logged in, sends a C command to the server,
which may suceed or fail at a later point.

=cut

sub change_nick
{
   my $self = shift;
   my ( $newnick ) = @_;

   if( !$self->is_connected ) {
      $self->_set_nick( $newnick );
   }
   else {
      $self->send_message( "NICK", undef, $newnick );
   }
}

############################
# Message handling methods #
############################

=head1 IRC v3.1 CAPABILITIES

The following methods relate to IRC v3.1 capabilities negotiations.

=cut

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

   my $supported = $self->{caps_supported} = $hints->{caps};

   my @request = grep { $supported->{$_} } @{$self->{use_caps}};

   if( @request ) {
      $self->{caps_enabled} = { map { $_ => undef } @request };
      $self->send_message( "CAP", undef, "REQ", join( " ", @request ) );
   }
   else {
      $self->send_message( "CAP", undef, "END" );
      ( $self->{on_cap_finished_f} //= $self->loop->new_future )->done;
   }

   return 1;
}

*on_message_cap_ACK = *on_message_cap_NAK = \&_on_message_cap_reply;
sub _on_message_cap_reply
{
   my $self = shift;
   my ( $message, $hints ) = @_;
   my $ack = $hints->{verb} eq "ACK";

   $self->{caps_enabled}{$_} = $ack for keys %{ $hints->{caps} };

   # Are any outstanding
   !defined and return 1 for values %{ $self->{caps_enabled} };

   ( $self->{on_cap_finished_f} //= $self->loop->new_future )->done;

   $self->adopt_future(
      Future->needs_all( @{ $self->{defer_cap_end_f} } )->then(
         sub { $self->send_message( "CAP", undef, "END" ); }
      )
   );

   return 1;
}

=head2 caps_supported

   $caps = $irc->caps_supported;

Returns a HASH whose keys give the capabilities listed by the server as
supported in its C response. If the server ignored the C
negotiation then this method returns C.

=cut

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

=head2 cap_supported

   $supported = $irc->cap_supported( $cap );

Returns a boolean indicating if the server supports the named capability.

=cut

sub cap_supported
{
   my $self = shift;
   my ( $cap ) = @_;
   return !!$self->{caps_supported}{$cap};
}

=head2 caps_enabled

   $caps = $irc->caps_enabled;

Returns a HASH whose keys give the capabilities successfully enabled by the
server as part of the C login sequence. If the server ignored the
C negotiation then this method returns C.

=cut

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

=head2 cap_enabled

   $enabled = $irc->cap_enabled( $cap );

Returns a boolean indicating if the client successfully enabled the named
capability.

=cut

sub cap_enabled
{
   my $self = shift;
   my ( $cap ) = @_;
   return !!$self->{caps_enabled}{$cap};
}

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

   if( $hints->{prefix_is_me} ) {
      $self->_set_nick( $hints->{new_nick} );
      return 1;
   }

   return 0;
}

sub on_message_RPL_WELCOME
{
   my $self = shift;
   my ( $message ) = @_;

   # set our nick to be what the server logged us in as
   $self->_set_nick( $message->{args}[0] );

   if( $self->{on_login_f} and @{ $self->{on_login_f} } ) {
      my @futures = @{ $self->{on_login_f} };
      undef $self->{on_login_f};

      foreach my $f ( @futures ) {
         $f->done( $self );
      }
   }

   # Don't eat it
   return 0;
}

sub on_message_AUTHENTICATE
{
   my $self = shift;
   my ( $message ) = @_;

   my $data = $message->arg( 0 );

   if( $data eq "+" ) {
      # Done
      my $data = $self->{authenticate_buffer} // "";
      my $f    = $self->{on_authenticate_f};

      undef @{$self}{qw( authenticate_buffer on_authenticate_f )};

      $f->done( $self, $data ) if $f;
      return 1;
   }

   $self->{authenticate_buffer} .= decode_base64( $data );

   return 1;
}

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

   ( $self->{on_sasl_complete_f} //= Future->new )->done( $message, $hints );

   return 0;
}

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

   # It's still complete even though it failed
   ( $self->{on_sasl_complete_f} //= Future->new )->done( $message, $hints );

   return 0;
}

=head1 MESSAGE-WRAPPING METHODS

The following methods are all inherited from L but are
mentioned again for convenient. For further details see the documentation in
the parent module.

In particular, each method returns a L instance.

=cut

=head2 do_PRIVMSG

=head2 do_NOTICE

   await $irc->do_PRIVMSG( target => $target, text => $text );

   await $irc->do_NOTICE( target => $target, text => $text );

Sends a C or C command.

=cut

=head1 SEE ALSO

=over 4

=item *

L - Internet Relay Chat: Client Protocol

=back

=head1 AUTHOR

Paul Evans

=cut

0x55AA;