Skip to content

Commit

Permalink
Fix parsing of client CTCPs, add comprehensive tests for BotTraffic p…
Browse files Browse the repository at this point in the history
…lugin
  • Loading branch information
hinrik committed Jan 22, 2009
1 parent 21d5495 commit 39d4ba1
Show file tree
Hide file tree
Showing 4 changed files with 156 additions and 17 deletions.
5 changes: 5 additions & 0 deletions Changes
@@ -1,5 +1,10 @@
Revision history for Perl extension POE::Component::IRC.

5.92
- Compat.pm: Fix parsing of CTCPs when no prefix is present
(i.e. client CTCPs) (Hinrik)
- Added tests for all events generated by the BotTraffic plugin (Hinrik)

5.90 Thu Jan 22 10:52:53 GMT 2009
- Seen.pod: Recipe for a bot implementing the 'seen' command (Hinrik)
- Reload.pod: How to reload your bot with out reconnecting (Hinrik)
Expand Down
1 change: 1 addition & 0 deletions MANIFEST
Expand Up @@ -92,6 +92,7 @@ t/04_plugins/01_plugman/01_load.t
t/04_plugins/02_connector/01_load.t
t/04_plugins/03_botaddressed/01_load.t
t/04_plugins/04_bottraffic/01_load.t
t/04_plugins/04_bottraffic/02_output.t
t/04_plugins/05_isupport/01_load.t
t/04_plugins/06_ctcp/01_load.t
t/04_plugins/07_console/01_load.t
Expand Down
43 changes: 26 additions & 17 deletions lib/POE/Filter/IRC/Compat.pm
Expand Up @@ -7,7 +7,7 @@ use POE::Filter::IRCD;
use File::Basename qw(fileparse);
use base qw(POE::Filter);

our $VERSION = '1.7';
our $VERSION = '1.8';

my %irc_cmds = (
qr/^\d{3}$/ => sub {
Expand Down Expand Up @@ -183,8 +183,8 @@ sub get_one {
return [ ];
}

if ($line->{raw_line} =~ tr/\001//) {
return $self->_get_ctcp( $line->{raw_line} );
if ($line->{command} =~ /^PRIVMSG|NOTICE$/ && $line->{params}->[1] =~ tr/\001//) {
return $self->_get_ctcp($line);
}

my $event = {
Expand Down Expand Up @@ -285,30 +285,36 @@ sub _decolon {

sub _get_ctcp {
my ($self, $line) = @_;
my ($who, $type, $where, $msg) = ($line =~ /^:(\S+) +(\S+) +(\S+) +:?(.*)$/) or return [];

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

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

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

my $events = [ ];
my ($name, $args);
CTCP: for my $string (@$ctcp) {
if (!(($name, $args) = $string =~ /^(\w+)(?: +(.*))?/)) {
warn "Received malformed CTCP message from $nick: $string\n" if $self->{debug};
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 ($type, $rest);

if (!(($type, $rest) = $args =~ /^(\w+) +(.+)/)) {
warn "Received malformed DCC request from $nick: $args\n" if $self->{debug};
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;

}
Expand All @@ -322,7 +328,10 @@ sub _get_ctcp {

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

Expand All @@ -333,27 +342,27 @@ sub _get_ctcp {
$type,
@dcc_args,
],
raw_line => $line,
raw_line => $line->{raw_line},
};
}
else {
push @$events, {
name => $type . '_' . lc $name,
args => [
$who,
[split /,/, $where],
$line->{prefix},
[split /,/, $line->{params}->[0]],
(defined $args ? $args : ''),
(defined $identified ? $identified : () ),
],
raw_line => $line,
raw_line => $line->{raw_line},
};
}
}

if ($text && @$text) {
my $what;
($what) = $line =~ /^(:\S+ +\w+ +\S+ +)/
or warn "What the heck? '$line'\n" if $self->{debug};
($what) = $line->{raw_line} =~ /^(:\S+ +\w+ +\S+ +)/
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};
Expand Down
124 changes: 124 additions & 0 deletions t/04_plugins/04_bottraffic/02_output.t
@@ -0,0 +1,124 @@
use strict;
use warnings;
use POE qw(Wheel::SocketFactory);
use POE::Component::IRC;
use POE::Component::IRC::Plugin::BotTraffic;
use POE::Component::IRC::Test::Harness;
use Socket;
use Test::More tests => 6;

my $irc = POE::Component::IRC->spawn( plugin_debug => 1 );
my $ircd = POE::Component::IRC::Test::Harness->spawn(
Alias => 'ircd',
Auth => 0,
AntiFlood => 0,
);
$irc->plugin_add(BotTraffic => POE::Component::IRC::Plugin::BotTraffic->new());

POE::Session->create(
package_states => [
main => [qw(
_start
_config_ircd
_shutdown
irc_001
irc_join
irc_disconnected
irc_bot_public
irc_bot_msg
irc_bot_action
)],
],
);

$poe_kernel->run();

sub _start {
my ($kernel, $heap) = @_[KERNEL, HEAP];

my $wheel = POE::Wheel::SocketFactory->new(
BindAddress => '127.0.0.1',
BindPort => 0,
SuccessEvent => '_fake_success',
FailureEvent => '_fake_failure',
);

if ($wheel) {
my $port = ( unpack_sockaddr_in( $wheel->getsockname ) )[0];
$kernel->yield(_config_ircd => $port );
$heap->{count} = 0;
$wheel = undef;
$kernel->delay(_shutdown => 60);
return;
}

$kernel->yield('_shutdown');
}

sub _config_ircd {
my ($kernel, $port) = @_[KERNEL, ARG0];

$kernel->post( 'ircd' => 'add_i_line' );
$kernel->post( 'ircd' => 'add_listener' => { Port => $port } );

$irc->yield(register => 'all');
$irc->yield(connect => {
nick => 'TestBot1',
server => '127.0.0.1',
port => $port,
ircname => 'Test test bot',
});
}

sub irc_001 {
my $irc = $_[SENDER]->get_heap();
pass('Logged in');
$irc->yield(join => '#testchannel');
}

sub irc_join {
my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1];
my $nick = ( split /!/, $who )[0];
my $irc = $sender->get_heap();

pass('Joined channel');
$irc->yield(privmsg => '#testchannel', 'A public message');
}

sub irc_bot_public {
my ($sender, $targets, $text) = @_[SENDER, ARG0, ARG1];
my $irc = $sender->get_heap();

is($text, 'A public message', 'irc_bot_public');
$irc->yield(privmsg => $irc->nick_name(), 'A private message');
}

sub irc_bot_msg {
my ($sender, $targets, $text) = @_[SENDER, ARG0, ARG1];
my $irc = $sender->get_heap();

is($text, 'A private message', 'irc_bot_msg');
$irc->yield(ctcp => 'TestBot1', 'ACTION some action');
}

sub irc_bot_action {
my ($sender, $targets, $text) = @_[SENDER, ARG0, ARG1];
my $irc = $sender->get_heap();

is($text, 'some action', 'irc_bot_action');
$irc->yield('quit');
}

sub irc_disconnected {
my ($kernel) = $_[KERNEL];
pass('irc_disconnected');
$kernel->yield('_shutdown');
}

sub _shutdown {
my ($kernel) = $_[KERNEL];
$kernel->alarm_remove_all();
$kernel->post(ircd => 'shutdown');
$irc->yield('shutdown');
}

0 comments on commit 39d4ba1

Please sign in to comment.