I believe the attached patch now implements an initial attempt at this.
Doesn't completely cover all of CAP's abilities, but enough to negotiate optional CAPs on login.
--
Paul Evans
=== modified file 'lib/Net/Async/IRC.pm'
--- lib/Net/Async/IRC.pm 2014-01-19 18:45:36 +0000
+++ lib/Net/Async/IRC.pm 2014-01-19 20:25:50 +0000
@@ -90,6 +90,11 @@
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
@@ -99,7 +104,7 @@
my $self = shift;
my %args = @_;
- for (qw( user realname )) {
+ for (qw( user realname use_caps )) {
$self->{$_} = delete $args{$_} if exists $args{$_};
}
@@ -269,10 +274,10 @@
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;
@@ -365,6 +370,126 @@
# Message handling methods #
############################
+=head1 IRC v3.1 CAPABILITIES
+
+The following methods relate to IRC v3.1 capabilities negotiations.
+
+=cut
+
+sub on_message_CAP
+{
+ my $self = shift;
+ my ( $message, $hints ) = @_;
+
+ my $verb = $message->arg(1);
+
+ my %hints = (
+ %$hints,
+ verb => $verb,
+ caps => { map { $_ => 1 } split m/ /, $message->arg(2) },
+ );
+
+ $self->invoke( "on_message_cap_$verb", $message, \%hints ) and $hints{handled} = 1;
+ $self->invoke( "on_message_cap", $verb, $message, \%hints ) and $hints{handled} = 1;
+
+ return $hints{handled};
+}
+
+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 = $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 $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 = $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 $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};
+}
+
+=head1 MESSAGE HANDLING
+
+=cut
+
sub on_message_NICK
{
my $self = shift;
=== added file 't/31client-cap.t'
--- t/31client-cap.t 1970-01-01 00:00:00 +0000
+++ t/31client-cap.t 2014-01-19 20:24:59 +0000
@@ -0,0 +1,100 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+use IO::Async::Test;
+use IO::Async::Loop;
+use IO::Async::Stream;
+
+use Net::Async::IRC;
+
+my $CRLF = "\x0d\x0a"; # because \r\n isn't portable
+
+my $loop = IO::Async::Loop->new();
+testing_loop( $loop );
+
+my ( $S1, $S2 ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!";
+
+# Normal CAP login
+{
+ my $irc = Net::Async::IRC->new(
+ handle => $S1,
+ use_caps => [qw( multi-prefix )],
+ );
+ $loop->add( $irc );
+
+ my $login_f = $irc->login(
+ nick => "MyNick",
+ user => "me",
+ realname => "My real name",
+ );
+
+ my $serverstream = "";
+ wait_for_stream { $serverstream =~ m/(?:.*$CRLF){3}/ } $S2 => $serverstream;
+
+ is( $serverstream, "CAP LS$CRLF" .
+ "USER me 0 * :My real name$CRLF" .
+ "NICK MyNick$CRLF", 'Server stream negotiates CAP' );
+ $serverstream = "";
+
+ $S2->syswrite( ':irc.example.com CAP * LS :multi-prefix sasl' . $CRLF );
+
+ wait_for_stream { $serverstream =~ m/.*$CRLF/ } $S2 => $serverstream;
+
+ is( $serverstream, "CAP REQ multi-prefix$CRLF", 'Client requests caps' );
+ $serverstream = "";
+
+ is_deeply( $irc->caps_supported,
+ { 'multi-prefix' => 1,
+ 'sasl' => 1 },
+ '$irc->caps_supported' );
+ ok( $irc->cap_supported( "multi-prefix" ), '$irc->cap_supported' );
+
+ $S2->syswrite( ':irc.example.com CAP * ACK :multi-prefix' . $CRLF );
+
+ wait_for_stream { $serverstream =~ m/.*$CRLF/ } $S2 => $serverstream;
+
+ is( $serverstream, "CAP END$CRLF", 'Client finishes CAP' );
+
+ is_deeply( $irc->caps_enabled,
+ { 'multi-prefix' => 1 },
+ '$irc->caps_enabled' );
+ ok( $irc->cap_enabled( "multi-prefix" ), '$irc->cap_enabled' );
+
+ $S2->syswrite( ':irc.example.com 001 MyNick :Welcome to IRC MyNick!me@your.host' . $CRLF );
+
+ wait_for { $login_f->is_ready };
+ $login_f->get;
+
+ $loop->remove( $irc );
+}
+
+# CAP ignored by server
+{
+ my $irc = Net::Async::IRC->new(
+ handle => $S1,
+ use_caps => [qw( multi-prefix )],
+ );
+ $loop->add( $irc );
+
+ my $login_f = $irc->login(
+ nick => "MyNick",
+ user => "me",
+ realname => "My real name",
+ );
+
+ my $serverstream = "";
+ wait_for_stream { $serverstream =~ m/(?:.*$CRLF){3}/ } $S2 => $serverstream;
+
+ $S2->syswrite( ':irc.example.com 001 MyNick :Welcome to IRC MyNick!me@your.host' . $CRLF );
+
+ wait_for { $login_f->is_ready };
+ $login_f->get;
+
+ is( $irc->caps_supported, undef, '$irc->caps_supported undef for CAPless server' );
+ is( $irc->caps_enabled, undef, '$irc->caps_enabled undef for CAPless server' );
+}
+
+done_testing;
RT for rt.cpan.org