File Coverage

blib/lib/Protocol/IRC/Message.pm

Criterion	Covered	Total	%
statement	110	115	95.6
branch	56	62	90.3
condition	11	12	91.6
subroutine	18	19	94.7
pod	15	15	100.0
total	210	223	94.1

#  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-2015 -- [e-mail]

package Protocol::IRC::Message;

use strict;
use warnings;

our $VERSION = '0.11';

use Carp;
our @CARP_NOT = qw( Net::Async::IRC );

=head1 NAME

C - encapsulates a single IRC message

=head1 SYNOPSIS

 use Protocol::IRC::Message;

 my $hello = Protocol::IRC::Message->new(
    "PRIVMSG",
    undef,
    "World",
    "Hello, world!"
 );

 printf "The command is %s and the final argument is %s\n",
    $hello->command, $hello->arg( -1 );

=head1 DESCRIPTION

An object in this class represents a single IRC message, either received from
or to be sent to the server. These objects are immutable once constructed, but
provide a variety of methods to access the contained information.

This class also understands IRCv3 message tags.

=cut

=head1 CONSTRUCTOR

=cut

=head2 new_from_line

   $message = Protocol::IRC::Message->new_from_line( $line )

Returns a new C object, constructed by parsing the
given IRC line. Most typically used to create a new object to represent a
message received from the server.

=cut

sub new_from_line
{
   my $class = shift;
   my ( $line ) = @_;

   my %tags;
   if( $line =~ s/^\@([^ ]+) +// ) {
      foreach ( split m/;/, $1 ) {
         if( m/^([^=]+)=(.*)$/ ) {
            $tags{$1} = $2;
         }
         else {
            $tags{$_} = undef;
         }
      }
   }

   my $prefix;
   if( $line =~ s/^:([^ ]+) +// ) {
      $prefix = $1;
   }

   my ( $mid, $final ) = split( m/ +:/, $line, 2 );
   my @args = split( m/ +/, $mid );

   push @args, $final if defined $final;

   my $command = shift @args;

   return $class->new_with_tags( $command, \%tags, $prefix, @args );
}

=head2 new

   $message = Protocol::IRC::Message->new( $command, $prefix, @args )

Returns a new C object, intialised from the given
components. Most typically used to create a new object to send to the server
using C. The message will contain no IRCv3 tags.

=cut

sub new
{
   my $class = shift;
   return $class->new_with_tags( $_[0], {}, $_[1], @_[2..$#_] );
}

=head2 new_with_tags

   $mesage = Protocol::IRC::Message->new_with_tags( $command, \%tags, $prefix, @args )

Returns a new C object, as with C but also
containing the given IRCv3 tags.

=cut

sub new_with_tags
{
   my $class = shift;
   my ( $command, $tags, $prefix, @args ) = @_;

   # IRC is case-insensitive for commands, but we'd like them in uppercase
   # to keep things simpler
   $command = uc $command;

   # Less strict checking than RFC 2812 because a lot of servers lately seem
   # to be more flexible than that.

   $command =~ m/^[A-Z]+$/ or $command =~ m/^\d\d\d$/ or
      croak "Command must be just letters or three digits";

   foreach my $key ( keys %$tags ) {
      $key =~ m{^[a-zA-Z0-9./-]+$} or
         croak "Tag key '$key' is invalid";

      my $value = $tags->{$key};
      defined $value and $value =~ m{[ ;]} and
         croak "Tag value '$value' for key '$key' is invalid";
   }

   if( defined $prefix ) {
      $prefix =~ m/[ \t\x0d\x0a]/ and
         croak "Prefix must not contain whitespace";
   }

   foreach ( @args[0 .. $#args-1] ) { # Not the final
      defined or croak "Argument must be defined";
      m/[ \t\x0d\x0a]/ and
         croak "Argument must not contain whitespace";
   }

   if( @args ) {
      defined $args[-1] or croak "Final argument must be defined";
      $args[-1] =~ m/[\x0d\x0a]/ and croak "Final argument must not contain a linefeed";
   }

   my $self = {
      command => $command,
      prefix  => $prefix,
      args    => \@args,
      tags    => { %$tags },
   };

   return bless $self, $class;
}

=head1 METHODS

=cut

=head2 STRING

   $str = $message->STRING

   $str = "$message"

Returns a string representing the message, suitable for use in a debugging
message or similar. I: This is not the same as the IRC wire form, to
send to the IRC server; for that see C.

=cut

use overload '""' => "STRING";
sub STRING
{
   my $self = shift;
   my $class = ref $self;
   return $class . "[" .
                    ( defined $self->{prefix} ? "prefix=$self->{prefix}," : "" ) .
                    "cmd=$self->{command}," .
                    "args=(" . join( ",", @{ $self->{args} } ) . ")]";
}

=head2 command

   $command = $message->command

Returns the command name or numeric stored in the message object.

=cut

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

=head2 command_name

   $name = $message->command_name

For named commands, returns the command name directly. For server numeric
replies, returns the name of the numeric.

=cut

my %NUMERIC_NAMES;

sub command_name
{
   my $self = shift;
   return $NUMERIC_NAMES{ $self->command } || $self->command;
}

=head2 tags

   $tags = $message->tags

Returns a HASH reference containing IRCv3 message tags. This is a reference to
the hash stored directly by the object itself, so the caller should be careful
not to modify it.

=cut

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

=head2 prefix

   $prefix = $message->prefix

Returns the line prefix stored in the object, or the empty string if one was
not supplied.

=cut

sub prefix
{
   my $self = shift;
   return defined $self->{prefix} ? $self->{prefix} : "";
}

=head2 prefix_split

   ( $nick, $ident, $host ) = $message->prefix_split

Splits the prefix into its nick, ident and host components. If the prefix
contains only a hostname (such as the server name), the first two components
will be returned as C.

=cut

sub prefix_split
{
   my $self = shift;

   my $prefix = $self->prefix;

   return ( $1, $2, $3 ) if $prefix =~ m/^(.*?)!(.*?)@(.*)$/;

   # $prefix doesn't split into nick!ident@host so presume host only
   return ( undef, undef, $prefix );
}

=head2 arg

   $arg = $message->arg( $index )

Returns the argument at the given index. Uses normal perl array indexing, so
negative indices work as expected.

=cut

sub arg
{
   my $self = shift;
   my ( $index ) = @_;
   return $self->{args}[$index];
}

=head2 args

   @args = $message->args

Returns a list containing all the message arguments.

=cut

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

=head2 stream_to_line

   $line = $message->stream_to_line

Returns a string suitable for sending the message to the IRC server.

=cut

sub stream_to_line
{
   my $self = shift;

   my $line = "";

   if( keys %{ $self->{tags} } ) {
      my $tags = $self->{tags};
      $line .= "\@" . join( ";", map { defined $tags->{$_} ? "$_=$tags->{$_}" : $_ } keys %$tags ) . " ";
   }

   if( defined $self->{prefix} ) {
      $line .= ":$self->{prefix} ";
   }

   $line .= $self->{command};

   foreach ( @{$self->{args}} ) {
      if( m/ / or m/^:/  ) {
         $line .= " :$_";
      }
      else {
         $line .= " $_";
      }
   }

   return $line;
}

# Argument naming information

# This hash holds HASH refs giving the names of the positional arguments of
# any message. The hash keys store the argument names, and the values store
# an argument index, the string "pn" meaning prefix nick, or "$n~$m" meaning
# an index range. Endpoint can be absent.

my %ARG_NAMES = (
   INVITE  => { inviter_nick => "pn",
                invited_nick => 0,
                target_name  => 1 },
   KICK    => { kicker_nick => "pn",
                target_name => 0,
                kicked_nick => 1,
                text        => 2 },
   MODE    => { target_name => 0,
                modechars   => 1,
                modeargs    => "2.." },
   NICK    => { old_nick => "pn",
                new_nick => 0 },
   NOTICE  => { targets => 0,
                text    => 1 },
   PING    => { text => 0 },
   PONG    => { text => 0 },
   QUIT    => { text => 0 },
   PART    => { target_name => 0,
                text        => 1 },
   PRIVMSG => { targets => 0,
                text    => 1 },
   TOPIC   => { target_name => 0,
                text        => 1 },
);

# Misc. named commands
$ARG_NAMES{$_} = { target_name => 0 } for qw(
   JOIN LIST NAMES WHO WHOIS WHOWAS
);

# TODO: 472 ERR_UNKNOWNMODE:  :is unknown mode char to me for
# How to parse this one??

=head2 arg_names

   $names = $message->arg_names

Returns a HASH reference giving details on how to parse named arguments for
the command given in this message.

This will be a hash whose keys give the names of the arguments, and the values
of these keys indicate how that argument is derived from the simple positional
arguments.

Normally this method is only called internally by the C method,
but is documented here for the benefit of completeness, and in case extension
modules wish to define parsing of new message types.

Each value should be one of the following:

=over 4

=item * String literal C

The value is a string, the nickname given in the message prefix

=item * NUMBER..NUMBER

The value is an ARRAY ref, containing a list of all the numbered arguments
between the (inclusive) given limits. Either or both limits may be negative;
they will count backwards from the end.

=item * NUMBER

The value is the argument at that numeric index. May be negative to count
backwards from the end.

=item * NUMBER@

The value is the argument at that numeric index as for C, except that
the result will be split on spaces and stored in an ARRAY ref.

=back

=cut

sub arg_names
{
   # Usage: Class->arg_names($command) or $self->arg_names()
   my $command;

   if( ref $_[0] ) {
      my $self = shift;
      $command = $self->{command};
   }
   else {
      my $class = shift; # ignore
      ( $command ) = @_;
      defined $command or croak 'Usage: '.__PACKAGE__.'->arg_names($command)';
   }

   return $ARG_NAMES{$command};
}

=head2 named_args

   $args = $message->named_args

Parses arguments in the message according to the specification given by the
C method. Returns a hash of parsed arguments.

TODO: More complete documentation on the exact arg names/values per message
type.

=cut

sub named_args
{
   my $self = shift;

   my $argnames = $self->arg_names or return;

   my %named_args;
   foreach my $name ( keys %$argnames ) {
      my $argindex = $argnames->{$name};

      my $value;
      if( $argindex eq "pn" ) {
         ( $value, undef, undef ) = $self->prefix_split;
      }
      elsif( $argindex =~ m/^(-?\d+)?\.\.(-?\d+)?$/ ) {
         my ( $start, $end ) = ( $1, $2 );
         my @args = $self->args;

         defined $start or $start = 0;
         defined $end   or $end = $#args;

         $end += @args if $end < 0;

         $value = [ splice( @args, $start, $end-$start+1 ) ];
      }
      elsif( $argindex =~ m/^-?\d+$/ ) {
         $value = $self->arg( $argindex );
      }
      elsif( $argindex =~ m/^(-?\d+)\@$/ ) {
         $value = [ split ' ', $self->arg( $1 ) ];
      }
      else {
         die "Unrecognised argument specification $argindex";
      }

      $named_args{$name} = $value;
   }

   return \%named_args;
}

=head2 gate_disposition

   $disp = $message->gate_disposition

Returns the "gating disposition" of the message. This defines how a reply
message from the server combines with other messages in response of a command
sent by the client. The disposition is either C, or a string consisting
of a type symbol and a gate name. If defined, the symbol defines what effect
it has on the gate name.

=over 4

=item -GATE

Adds more information to the response for that gate, but doesn't yet complete
it.

=item +GATE

Completes the gate with a successful result.

=item !GATE

Completes the gate with a failure result.

=back

=cut

my %GATE_DISPOSITIONS;

sub gate_disposition
{
   my $self = shift;
   return $GATE_DISPOSITIONS{ $self->command };
}

=head1 AUTHOR

Paul Evans

=cut

local $_;
while(  ) {
   chomp;
   my ( $numname, $args, $gating ) = split m/\s*\|\s*/, $_ or next;
   my ( $num, $name ) = split m/=/, $numname;

   my $index = 0;
   my %args = map {
      if( m/^(.*)=(.*)$/ ) {
         $index = $1;
         ( $2 => $1 )
      }
      else {
         ( $_ => ++$index );
      }
   } split m/,/, $args;

   $NUMERIC_NAMES{$num} = $name;
   $ARG_NAMES{$num} = \%args;
   $GATE_DISPOSITIONS{$num} = $gating if defined $gating;
}
close DATA;

0x55AA;

# And now the actual numeric definitions, given in columns
# number=NAME | argname,argname,argname

# arg may be position=argname

# See also
#   http://www.alien.net.au/irc/irc2numerics.html

__DATA__