File Coverage

blib/lib/Parse/IRC.pm

Criterion	Covered	Total	%
statement	67	110	60.9
branch	22	82	26.8
condition	12	22	54.5
subroutine	9	11	81.8
pod	3	3	100.0
total	113	228	49.5

package Parse::IRC;
$Parse::IRC::VERSION = '1.22';
#ABSTRACT: A parser for the IRC protocol.

# We export some stuff
require Exporter;
@ISA = qw[Exporter];
@EXPORT = qw[parse_irc];

use strict;
use warnings;
use File::Basename qw[fileparse];

my $g = {
  space			=> qr/\x20+/o,
  trailing_space	=> qr/\x20*/o,
};

my $irc_regex = qr/^
  (?:
    \x3a                #  : comes before hand
    (\S+)               #  [prefix]
    $g->{'space'}       #  Followed by a space
  )?                    # but is optional.
  (
    \d{3}|[a-zA-Z]+     #  [command]
  )                     # required.
  (?:
    $g->{'space'}       # Strip leading space off [middle]s
    (                   # [middle]s
      (?:
        [^\x00\x0a\x0d\x20\x3a]
        [^\x00\x0a\x0d\x20]*
      )                 # Match on 1 of these,
      (?:
        $g->{'space'}
        [^\x00\x0a\x0d\x20\x3a]
        [^\x00\x0a\x0d\x20]*
      )*           # then match on 0-13 of these,
    )
  )?                    # otherwise dont match at all.
  (?:
    $g->{'space'}\x3a   # Strip off leading spacecolon for [trailing]
    ([^\x00\x0a\x0d]*)	# [trailing]
  )?                    # [trailing] is not necessary.
  $g->{'trailing_space'}
$/x;

# the magic cookie jar
my %dcc_types = (
    qr/^(?:CHAT|SEND)$/ => sub {
        my ($nick, $type, $args) = @_;
        my ($file, $addr, $port, $size);
        return if !(($file, $addr, $port, $size) = $args =~ /^(".+"|[^ ]+) +([0-9a-fA-F:]+) +(\d+)(?: +(\d+))?/);

        if ($file =~ s/^"//) {
            $file =~ s/"$//;
            $file =~ s/\\"/"/g;
        }
        $file = fileparse($file);

        return (
            $port,
            {
                nick => $nick,
                type => $type,
                file => $file,
                size => $size,
                addr => $addr,
                port => $port,
            },
            $file,
            $size,
            $addr,
        );
    },
    qr/^(?:ACCEPT|RESUME)$/ => sub {
        my ($nick, $type, $args) = @_;
        my ($file, $port, $position);
        return if !(($file, $port, $position) = $args =~ /^(".+"|[^ ]+) +(\d+) +(\d+)/);

        $file =~ s/^"|"$//g;
        $file = fileparse($file);

        return (
            $port,
            {
                nick => $nick,
                type => $type,
                file => $file,
                size => $position,
                port => $port,
            },
            $file,
            $position,
        );
    },
);

sub parse_irc {
  my $string = shift || return;
  return __PACKAGE__->new(@_)->parse($string);
}

sub new {
  my $package = shift;
  my %opts = @_;
  $opts{lc $_} = delete $opts{$_} for keys %opts;
  return bless \%opts, $package;
}

sub parse {
  my $self = shift;
  my $raw_line = shift || return;
  $raw_line =~ s/(\x0D\x0A?|\x0A\x0D?)$//;
  if ( my($prefix, $command, $middles, $trailing) = $raw_line =~ m/$irc_regex/ ) {
      my $event = { raw_line => $raw_line };
      $event->{'prefix'} = $prefix if $prefix;
      $event->{'command'} = uc $command;
      $event->{'params'} = [] if ( defined ( $middles ) || defined ( $trailing ) );
      push @{$event->{'params'}}, (split /$g->{'space'}/, $middles) if defined ( $middles );
      push @{$event->{'params'}}, $trailing if defined( $trailing );
      if ( $self->{ctcp} and $event->{'command'} =~ /^(PRIVMSG|NOTICE)$/ and $event->{params}->[1] =~ tr/\001// ) {
        return $self->_get_ctcp( $event );
      }
      if ( $self->{public} and $event->{'command'} eq 'PRIVMSG' and $event->{'params'}->[0] =~ /^(\x23|\x26)/ ) {
	$event->{'command'} = 'PUBLIC';
      }
      return $event;
  }
  else {
      warn "Received line $raw_line that is not IRC protocol\n" if $self->{debug};
  }
  return;
}

sub _get_ctcp {
    my ($self, $line) = @_;

    # Is this a CTCP request or reply?
    my $ctcp_type = $line->{command} eq 'PRIVMSG' ? 'CTCP' : 'CTCPREPLY';

    # CAPAP IDENTIFY-MSG is only applied to ACTIONs
    my ($msg, $identified) = ($line->{params}->[1], undef);
    ($msg, $identified) = _split_idmsg($msg) if $self->{identifymsg} && $msg =~ /^.ACTION/;

    my $events;
    my ($ctcp, $text) = _ctcp_dequote($msg);

    if (!defined $ctcp) {
        warn "Received malformed CTCP message: $msg\n" if $self->{debug};
        return $events;
    }

    my $nick = defined $line->{prefix} ? (split /!/, $line->{prefix})[0] : undef;

    # We only process the first CTCP. The only people who send multiple ones
    # are those who are trying to flood our outgoing queue anyway (e.g. by
    # having us reply to 20 VERSION requests at a time).
    my ($name, $args);
    CTCP: for my $string ($ctcp->[0]) {
        if (!(($name, $args) = $string =~ /^(\w+)(?: +(.*))?/)) {
            defined $nick
                ? do { warn "Received malformed CTCP message from $nick: $string\n" if $self->{debug} }
                : do { warn "Trying to send malformed CTCP message: $string\n" if $self->{debug} }
            ;
            last CTCP;
        }

        if (lc $name eq 'dcc') {
            my ($dcc_type, $rest);

            if (!(($dcc_type, $rest) = $args =~ /^(\w+) +(.+)/)) {
                defined $nick
                    ? do { warn "Received malformed DCC request from $nick: $args\n" if $self->{debug} }
                    : do { warn "Trying to send malformed DCC request: $args\n" if $self->{debug} }
                ;
                last CTCP;

            }
            $dcc_type = uc $dcc_type;

            my ($handler) = grep { $dcc_type =~ /$_/ } keys %dcc_types;
            if (!$handler) {
                warn "Unhandled DCC $dcc_type request: $rest\n" if $self->{debug};
                last CTCP;
            }

            my @dcc_args = $dcc_types{$handler}->($nick, $dcc_type, $rest);
            if (!@dcc_args) {
                defined $nick
                    ? do { warn "Received malformed DCC $dcc_type request from $nick: $rest\n" if $self->{debug} }
                    : do { warn "Trying to send malformed DCC $dcc_type request: $rest\n" if $self->{debug} }
                ;
                last CTCP;
            }

            $events = {
                prefix => $line->{prefix},
                command => 'DCC_REQUEST',
                params => [
                    $dcc_type,
                    @dcc_args,
                ],
                raw_line => $line->{raw_line},
            };
        }
        else {
            $events = {
                command => $ctcp_type . '_' . uc $name,
                prefix => $line->{prefix},
                params => [
                    $line->{params}->[0],
                    (defined $args ? $args : ''),
                    (defined $identified ? $identified : () ),
                ],
                raw_line => $line->{raw_line},
            };
        }
    }

    # XXX: I'm not quite sure what this is for, but on FreeNode it adds an
    # extra bogus event and displays a debug message, so I have disabled it.
    # FreeNode precedes PRIVMSG and CTCP ACTION messages with '+' or '-'.
    #if ($text && @$text) {
    #    my $what;
    #    ($what) = $line->{raw_line} =~ /^(:[^ ]+ +\w+ +[^ ]+ +)/
    #        or warn "What the heck? '".$line->{raw_line}."'\n" if $self->{debug};
    #    $text = (defined $what ? $what : '') . ':' . join '', @$text;
    #    $text =~ s/\cP/^P/g;
    #    warn "CTCP: $text\n" if $self->{debug};
    #    push @$events, @{ $self->{_ircd}->get([$text]) };
    #}

    return $events;
}

sub _split_idmsg {
    my ($line) = @_;
    my ($identified, $msg) = split //, $line, 2;
    $identified = $identified eq '+' ? 1 : 0;
    return $msg, $identified;
}

# Splits a message into CTCP and text chunks. This is gross. Most of
# this is also stolen from Net::IRC, but I (fimm) wrote that too, so it's
# used with permission. ;-)
sub _ctcp_dequote {
    my ($msg) = @_;
    my (@chunks, $ctcp, $text);

    # CHUNG! CHUNG! CHUNG!

    if (!defined $msg) {
        die 'Not enough arguments to Parse::IRC::_ctcp_dequote';
    }

    # Strip out any low-level quoting in the text.
    $msg = _low_dequote( $msg );

    # Filter misplaced \001s before processing... (Thanks, tchrist!)
    substr($msg, rindex($msg, "\001"), 1, '\\a')
        if ($msg =~ tr/\001//) % 2 != 0;

    return if $msg !~ tr/\001//;

    @chunks = split /\001/, $msg;
    shift @chunks if !length $chunks[0]; # FIXME: Is this safe?

    for (@chunks) {
        # Dequote unnecessarily quoted chars, and convert escaped \'s and ^A's.
        s/\\([^\\a])/$1/g;
        s/\\\\/\\/g;
        s/\\a/\001/g;
    }

    # If the line begins with a control-A, the first chunk is a CTCP
    # message. Otherwise, it starts with text and alternates with CTCP
    # messages. Really stupid protocol.
    if ($msg =~ /^\001/) {
        push @$ctcp, shift @chunks;
    }

    while (@chunks) {
        push @$text, shift @chunks;
        push @$ctcp, shift @chunks if @chunks;
    }

    return ($ctcp, $text);
}

# Quotes a string in a low-level, protocol-safe, utterly brain-dead
# fashion. Returns the quoted string.
sub _low_quote {
    my ($line) = @_;
    my %enquote = ("\012" => 'n', "\015" => 'r', "\0" => '0', "\cP" => "\cP");

    if (!defined $line) {
        die 'Not enough arguments to Parse::IRC->_low_quote';
    }

    if ($line =~ tr/[\012\015\0\cP]//) { # quote \n, \r, ^P, and \0.
        $line =~ s/([\012\015\0\cP])/\cP$enquote{$1}/g;
    }

    return $line;
}

# Does low-level dequoting on CTCP messages. I hate this protocol.
# Yes, I copied this whole section out of Net::IRC.
sub _low_dequote {
    my ($line) = @_;
    my %dequote = (n => "\012", r => "\015", 0 => "\0", "\cP" => "\cP");

    if (!defined $line) {
        die 'Not enough arguments to Parse::IRC->_low_dequote';
    }

    # dequote \n, \r, ^P, and \0.
    # Thanks to Abigail ([e-mail]) for this clever bit.
    if ($line =~ tr/\cP//) {
        $line =~ s/\cP([nr0\cP])/$dequote{$1}/g;
    }

    return $line;
}

q[Operation Blackbriar];

__END__