File Coverage

blib/lib/POE/Filter/IRCv3.pm

Criterion	Covered	Total	%
statement	143	146	97.9
branch	50	62	80.6
condition	14	19	73.6
subroutine	17	17	100.0
pod	10	10	100.0
total	234	254	92.1

package POE::Filter::IRCv3;
$POE::Filter::IRCv3::VERSION = '1.001001';
use strict; use warnings FATAL => 'all';

use Carp;

BEGIN {
  if (eval { require POE::Filter; 1 }) {
    our @ISA = 'POE::Filter';
  }
}

=pod

=for Pod::Coverage COLONIFY DEBUG BUFFER SPCHR

=cut

sub COLONIFY () { 0 }
sub DEBUG    () { 1 }
sub BUFFER   () { 2 }
sub SPCHR    () { "\x20" }

our %CharToEscapedTag = (
  ';'  => '\:',
  ' '  => '\s',
  "\0" => '\0',
  "\\" => '\\',
  "\r" => '\r',
  "\n" => '\n',
  "\a" => '\a',
);

our %EscapedTagToChar = reverse %CharToEscapedTag;

sub new {
  my ($class, %params) = @_;
  map {; $params{uc $_} = $params{$_} } keys %params;
  bless [
    ($params{'COLONIFY'} || 0),
    ($params{'DEBUG'}    || $ENV{POE_FILTER_IRC_DEBUG} || 0),
    []  ## BUFFER
  ], $class
}

sub clone {
  my ($self) = @_;
  my $nself = [@$self];
  $nself->[BUFFER] = [];
  bless $nself, ref $self
}

sub debug {
  my ($self, $value) = @_;
  return $self->[DEBUG] = $value if defined $value;
  $self->[DEBUG]
}

sub colonify {
  my ($self, $value) = @_;
  return $self->[COLONIFY] = $value if defined $value;
  $self->[COLONIFY]
}


sub get_one_start {
  my ($self, $raw_lines) = @_;
  push @{ $self->[BUFFER] }, $_ for @$raw_lines;
}

sub get_pending {
  my ($self) = @_;
  @{ $self->[BUFFER] } ? [ @{ $self->[BUFFER] } ] : ()
}

sub get {
  my @events;
  for my $raw_line (@{ $_[1] }) {
    warn " >> '$raw_line'\n" if $_[0]->[DEBUG];
    if ( my $event = parse_one_line($raw_line) ) {
      push @events, $event;
    } else {
      carp "Received malformed IRC input: $raw_line";
    }
  }
  \@events
}

sub get_one {
  my ($self) = @_;
  my @events;
  if ( my $raw_line = shift @{ $self->[BUFFER] } ) {
    warn " >> '$raw_line'\n" if $self->[DEBUG];
    if ( my $event = parse_one_line($raw_line) ) {
      push @events, $event;
    } else {
      warn "Received malformed IRC input: $raw_line\n";
    }
  }
  \@events
}


use bytes;
no warnings 'substr';

sub put {
  my ($self, $events) = @_;
  my $raw_lines = [];

  for my $event (@$events) {

    if ( ref $event eq 'HASH' ) {
      my $raw_line;

      ## FIXME this gets glacially slow ->
      if ( exists $event->{tags} && (my @tags = %{ $event->{tags} }) ) {
          $raw_line .= '@';
          while (my ($thistag, $thisval) = splice @tags, 0, 2) {
            $raw_line .= $thistag;
            if (defined $thisval) {
              $raw_line .= '=';
              my $tag_pos = 0;
              my $len = length $thisval;
              while ($tag_pos < $len) {
                my $ch = substr $thisval, $tag_pos++, 1;
                $raw_line .= exists $CharToEscapedTag{$ch} ?
                  $CharToEscapedTag{$ch} : $ch
              }
            }
            $raw_line .= ';' if @tags;
          }
          $raw_line .= ' ';
      }

      $raw_line .= ':' . $event->{prefix} . ' ' if $event->{prefix};
      $raw_line .= $event->{command};

      if ( $event->{params} && (my @params = @{ $event->{params} }) ) {
          $raw_line .= ' ';
          my $param = shift @params;
          while (@params) {
            $raw_line .= $param . ' ';
            $param = shift @params;
          }
          $raw_line .= ':'
            if (index($param, SPCHR) != -1)
            or (index($param, ':') == 0)
            or (
              defined $event->{colonify} ?
              $event->{colonify} : $self->[COLONIFY]
            );
          $raw_line .= $param;
      }

      push @$raw_lines, $raw_line;
      warn " << '$raw_line'\n" if $self->[DEBUG];
    } else {
      carp "($self) non-HASH passed to put(): '$event'";
      push @$raw_lines, $event if ref $event eq 'SCALAR';
    }

  }

  $raw_lines
}


sub parse_one_line {
  my $raw_line = $_[0];
  my %event = ( raw_line => $raw_line );
  my $pos = 0;

  ## We cheat a little; the spec is fuzzy when it comes to CR, LF, and NUL
  ## bytes. Theoretically they're not allowed inside messages, but
  ## that's really an implementation detail (and the spec agrees).
  ## We just stick to SPCHR (\x20) here.

  if ( substr($raw_line, 0, 1) eq '@' ) {
    return unless (my $nextsp = index($raw_line, SPCHR)) > 0;
    # Tag parser cheats and uses split, at the moment:
    for ( split /;/, substr $raw_line, 1, ($nextsp - 1) ) {
          my ($thistag, $thisval) = split /=/;
          my $realval;
          if (defined $thisval) {
            my $tag_pos = 0;
            my $len = length $thisval;
            while ($tag_pos < $len) {
              my $ch = substr $thisval, $tag_pos++, 1;
              if ($ch eq "\\") {
                my $pair = $ch . (substr $thisval, $tag_pos++, 1 || '');
                if (exists $EscapedTagToChar{$pair}) {
                  $realval .= $EscapedTagToChar{$pair}
                } else {
                  $realval .= substr $pair, 1, 1;
                }
              } else {
                $realval .= $ch
              }
            }
          }
          $event{tags}->{$thistag} = $realval
    }
    $pos = $nextsp + 1;
  }

  $pos++ while substr($raw_line, $pos, 1) eq SPCHR;

  if ( substr($raw_line, $pos, 1) eq ':' ) {
    my $nextsp;
    ($nextsp = index $raw_line, SPCHR, $pos) > 0 and length(
        $event{prefix} = substr $raw_line, ($pos + 1), ($nextsp - $pos - 1)
    ) or return;
    $pos = $nextsp + 1;
    $pos++ while substr($raw_line, $pos, 1) eq SPCHR;
  }

  my $nextsp_maybe;
  if ( ($nextsp_maybe = index $raw_line, SPCHR, $pos) == -1 ) {
    # No more spaces; do we have anything..?
    my $cmd = substr $raw_line, $pos;
    $event{command} = uc( length $cmd ? $cmd : return );
    return \%event
  }

  $event{command} = uc(
    substr($raw_line, $pos, ($nextsp_maybe - $pos) )
  );
  $pos = $nextsp_maybe + 1;

  $pos++ while substr($raw_line, $pos, 1) eq SPCHR;

  my $maxlen = length $raw_line;
  PARAM: while ( $pos < $maxlen ) {
    if ( substr($raw_line, $pos, 1) eq ':' ) {
      push @{ $event{params} }, substr $raw_line, ($pos + 1);
      last PARAM
    }
    if ( (my $nextsp = index $raw_line, SPCHR, $pos) == -1 ) {
      push @{ $event{params} }, substr $raw_line, $pos;
      last PARAM
    } else {
      push @{ $event{params} }, substr $raw_line, $pos, ($nextsp - $pos);
      $pos = $nextsp + 1;
      $pos++ while substr($raw_line, $pos, 1) eq SPCHR;
      next PARAM
    }
  }

  \%event
}


no bytes;


print
  qq[ let's try this again -without- the part where we beat you to],
  qq[ death with a six foot plush toy of sexual harassment panda\n ]
unless caller; 1;


=pod

=head1 NAME

POE::Filter::IRCv3 - Fast IRCv3.2 parser for POE or stand-alone use

=head1 SYNOPSIS

  my $filter = POE::Filter::IRCv3->new(colonify => 1);

  # Raw lines parsed to hashes:
  my $array_of_refs  = $filter->get(
    [
      ':prefix COMMAND foo :bar',
      '@foo=bar;baz :prefix COMMAND foo :bar',
    ]
  );

  # Hashes deparsed to raw lines:
  my $array_of_lines = $filter->put(
    [
      {
        prefix  => 'prefix',
        command => 'COMMAND',
        params  => [
          'foo',
          'bar'
        ],
      },
      {
        prefix  => 'prefix',
        command => 'COMMAND',
        params  => [
          'foo',
          'bar'
        ],
        tags => {
          foo => 'bar',
          baz => undef,
        },
      },
    ]
  );


  # Stacked with a line filter, suitable for Wheel usage, etc:
  my $ircd = POE::Filter::IRCv3->new(colonify => 1);
  my $line = POE::Filter::Line->new(
    InputRegexp   => '\015?\012',
    OutputLiteral => "\015\012",
  );
  my $stacked = POE::Filter::Stackable->new(
    Filters => [ $line, $ircd ],
  );

  # Functional parser interface:
  my $event = POE::Filter::IRCv3::parse_one_line(
    ':foo PRIVMSG #bar :baz quux'
  );

=head1 DESCRIPTION

A L for IRC traffic with support for IRCv3.2 message tags.

Does not rely on regular expressions for parsing.  Benchmarks show this
approach is generally faster on the most common IRC strings.

Like any proper L, there are no POE-specific bits involved here
-- the filter can be used stand-alone to parse lines of IRC traffic (also see
L).

In fact, you do not need L installed -- if L is not
available, it is left out of C<@ISA> and the filter will continue working
normally.

=head2 POE / Object interface

=head3 new

Construct a new Filter; if the B option is true,
the last parameter will always have a colon prepended.
(This setting can also be retrieved or changed on-the-fly by calling
B as a method, or changed for specific events by passing a
B option via events passed to L.)

=head3 get_one_start, get_one, get_pending

Implement the interface described in L.

See L.

=head3 get

  my $events = $filter->get( [ $line, $another, ... ] );
  for my $event (@$events) {
    my $cmd = $event->{command};
    ## See below for other keys available
  }

Takes an ARRAY of raw lines and returns an ARRAY of HASH-type references with
the following keys:

=head4 command

The (uppercased) command or numeric.

=head4 params

An ARRAY containing the event parameters.

=head4 prefix

The sender prefix, if any.

=head4 tags

A HASH of key => value pairs matching IRCv3.2 "message tags" -- see
L.

Note that a tag can be present, but have an undefined value.

=head3 put

  my $lines = $filter->put( [ $hash, $another_hash, ... ] );
  for my $line (@$lines) {
    ## Direct to socket, etc
  }

Takes an ARRAY of HASH-type references matching those described in L
(documented above) and returns an ARRAY of raw IRC-formatted lines.

=head4 colonify

In addition to the keys described in L, the B option can be
specified for specific events. This controls whether or not the last
parameter will be colon-prefixed even if it is a single word. (Yes, IRC is
woefully inconsistent ...)

Specify as part of the event hash:

  $filter->put([ { %event, colonify => 1 } ]);

=head3 clone

Copy the filter object (with a cleared buffer).

=head3 debug

Turn on/off debug output, which will display every input/output line (and
possibly other data in the future).

This is enabled by default at construction time if the environment variable
C is a true value.

=head2 Functional interface

=head3 parse_one_line

If the filter is being used as a stand-alone IRC parser and speed is of the
essence, you can skip method resolution & queue handling by calling the parse
function directly using the fully-qualified name:

  my $ev = POE::Filter::IRCv3::parse_one_line( $line );

The function takes a single line and returns a HASH whose structure is
described in the documentation for L, above.

If the given line cannot be parsed, the function returns false (rather than
throwing an exception, as L would).

There is currently no functional interface to message string composition
(L).

=head1 AUTHOR

Jon Portnoy

Licensed under the same terms as Perl.

Original implementations were derived from L,
which is copyright Chris Williams and Jonathan Steinert. This codebase has
diverged significantly.

Major thanks to the C<#ircv3> crew on irc.atheme.org, especially C and
C, for various bits of inspiration.

=head1 SEE ALSO

L

L

L

L

L

L

=cut