#  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-2017 -- leonerd@leonerd.org.uk

package Net::Async::IRC;

use strict;
use warnings;

our $VERSION = '0.11';

# 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 Carp;

use Socket qw( SOCK_STREAM );

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

=head1 NAME

C<Net::Async::IRC> - use IRC with C<IO::Async>

=head1 SYNOPSIS

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

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

 $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<IO::Async>.

Most of the actual IRC message handling behaviour is implemented by the parent
class L<Net::Async::IRC::Protocol>.

Most of the behaviour related to being an IRC client is implemented by the
parent class L<Protocol::IRC::Client>.

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($>) );

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

=head1 PARAMETERS

The following named parameters may be passed to C<new> or C<configure>:

=over 8

=item nick => STRING

=item user => STRING

=item realname => STRING

Connection details. See also C<connect>, C<login>.

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

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

If logged in, changing the C<nick> property is equivalent to calling
C<change_nick>. 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.

=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 with a trailing call to C<< ->get >> return
L<Future> instances.

=cut

=head2 connect

   $irc = $irc->connect( %args )->get

Connects to the IRC server. This method does not perform the complete IRC
login sequence; for that see instead the C<login> method. The returned
L<Future> 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<IO::Async::Loop>
C<connect> 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<login> 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 = $irc->login( %args )->get

Logs in to the IRC network, connecting first using the C<connect> 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<new> or C<configure>
methods.

=item pass => STRING

Server password to connect with.

=back

Any other arguments that are passed, are forwarded to the C<connect> method if
it is required; i.e. if C<login> 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

=cut

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

   return $self->{login_f} ||= $self->connect( %args )->then( sub {
      $self->send_message( "CAP", undef, "LS" ) if $self->{use_caps};

      $self->send_message( "PASS", undef, $pass ) if defined $pass;
      $self->send_message( "USER", undef, $user, "0", "*", $realname );
      $self->send_message( "NICK", undef, $nick );

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

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

      return $f;
   })->on_fail( sub { undef $self->{login_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<NICK> 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" );
   }

   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->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<CAP LS> response. If the server ignored the C<CAP>
negotiation then this method returns C<undef>.

=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<CAP REQ> login sequence. If the server ignored the
C<CAP> negotiation then this method returns C<undef>.

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

=head1 MESSAGE-WRAPPING METHODS

The following methods are all inherited from L<Protocol::IRC::Client> but are
mentioned again for convenient. For further details see the documentation in
the parent module.

In particular, each method returns a L<Future> instance.

=cut

=head2 do_PRIVMSG

=head2 do_NOTICE

   $irc->do_PRIVMSG( target => $target, text => $text )->get

   $irc->do_NOTICE( target => $target, text => $text )->get

Sends a C<PRIVMSG> or C<NOITICE> command.

=cut

=head1 SEE ALSO

=over 4

=item *

L<http://tools.ietf.org/html/rfc2812> - Internet Relay Chat: Client Protocol

=back

=head1 AUTHOR

Paul Evans <leonerd@leonerd.org.uk>

=cut

0x55AA;