package POE::Filter::IRCv3;
$POE::Filter::IRCv3::VERSION = '0.047002';
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 (
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 my $tag_pair
( split /;/, substr $raw_line, 1, ($nextsp - 1) ) {
my ($thistag, $thisval) = split /=/, $tag_pair;
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[<mst> 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
=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<POE::Filter> for IRC traffic with support for IRCv3.2 message tags.
Does not rely on regular expressions for parsing (unless tags are present --
in which case escaping takes place via regex). Benchmarks show this approach
is slightly faster on most strings.
Like any proper L<POE::Filter>, there are no POE-specific bits involved here
-- the filter can be used stand-alone to parse lines of IRC traffic (also see
L<IRC::Toolkit::Parser>).
In fact, you do not need L<POE> installed -- if L<POE::Filter> 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<colonify> 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<colonify> as a method, or changed for specific events by passing a
B<colonify> option via events passed to L</put>.)
=head3 get_one_start, get_one, get_pending
Implement the interface described in L<POE::Filter>.
See L</get>.
=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<http://ircv3.atheme.org>.
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</get>
(documented above) and returns an ARRAY of raw IRC-formatted lines.
=head4 colonify
In addition to the keys described in L</get>, the B<colonify> 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<POE_FILTER_IRC_DEBUG> 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</get>, above.
If the given line cannot be parsed, the function returns false (rather than
throwing an exception, as L</get> would).
There is currently no functional interface to message string composition
(L</put>).
=head1 AUTHOR
Jon Portnoy <avenj@cobaltirc.org>
Licensed under the same terms as Perl.
Original implementations were derived from L<POE::Filter::IRCD>,
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<Aerdan> and
C<grawity>, for various bits of inspiration.
=head1 SEE ALSO
L<IRC::Message::Object>
L<POE::Filter>
L<POE::Filter::IRCD>
L<POE::Filter::Line>
L<POE::Filter::Stackable>
L<IRC::Toolkit>
=cut