546 lines
20 KiB
Perl
546 lines
20 KiB
Perl
#! /usr/bin/perl -wT
|
|
|
|
# If you edit this file, please check carefully that the garbage
|
|
# collection isn't broken. POE is sometimes too clever for our good
|
|
# in finding references to sessions, and keeps running even after we
|
|
# want to stop.
|
|
# $Id: test-driver.pl 1419 2005-05-31 00:26:19Z entrope $
|
|
|
|
# This interprets a simple scripting language. Lines starting with a
|
|
# hash mark (#, aka octothorpe, pound sign, etc) are ignored. The
|
|
# special commands look like this, where angle brackets indicate a
|
|
# metavariable:
|
|
# define <macro> <value>
|
|
# undef <macro>
|
|
# connect <name> <nick> <ident> <server> :<userinfo>
|
|
# sync <name1>,<name2>[,<name3>]*
|
|
# :<name> <command>[ <args]*
|
|
# For the last line syntax, <command> may be an IRC or IRC-like
|
|
# command. Supported non-IRC commands are:
|
|
# :<name> expect <source|*name2> [...]
|
|
# :<name> raw <text>
|
|
# :<name> sleep <seconds>
|
|
# :<name> wait <name2>
|
|
|
|
require 5.006;
|
|
|
|
use bytes;
|
|
use warnings;
|
|
use strict;
|
|
use vars;
|
|
use constant DELAY => 2;
|
|
use constant EXPECT_TIMEOUT => 15;
|
|
use constant RECONNECT_TIMEOUT => 5;
|
|
use constant THROTTLED_TIMEOUT => 90;
|
|
|
|
use FileHandle;
|
|
use POE;
|
|
use POE::Component::IRC;
|
|
|
|
# this defines commands that take "zero time" to execute
|
|
# (specifically, those which do not send commands from the issuing
|
|
# client to the server)
|
|
our $zero_time = {
|
|
expect => 1,
|
|
sleep => 1,
|
|
wait => 1,
|
|
};
|
|
|
|
# Create the main session and start POE.
|
|
# All the empty anonymous subs are just to make POE:Session::ASSERT_STATES happy.
|
|
POE::Session->create(inline_states =>
|
|
{
|
|
# POE kernel interaction
|
|
_start => \&drv_start,
|
|
_child => sub {},
|
|
_stop => sub {
|
|
my $heap = $_[HEAP];
|
|
print "\nThat's all, folks!";
|
|
print "(exiting at line $heap->{lineno}: $heap->{line})"
|
|
if $heap->{line};
|
|
print "\n";
|
|
},
|
|
_default => \&drv_default,
|
|
# generic utilities or miscellaneous functions
|
|
heartbeat => \&drv_heartbeat,
|
|
timeout_expect => \&drv_timeout_expect,
|
|
reconnect => \&drv_reconnect,
|
|
enable_client => sub { $_[ARG0]->{ready} = 1; },
|
|
disable_client => sub { $_[ARG0]->{ready} = 0; },
|
|
die => sub { $_[KERNEL]->signal($_[SESSION], 'TERM'); },
|
|
# client-based command issuers
|
|
cmd_die => \&cmd_generic,
|
|
cmd_expect => \&cmd_expect,
|
|
cmd_invite => \&cmd_generic,
|
|
cmd_join => \&cmd_generic,
|
|
cmd_mode => \&cmd_generic,
|
|
cmd_nick => \&cmd_generic,
|
|
cmd_notice => \&cmd_message,
|
|
cmd_oper => \&cmd_generic,
|
|
cmd_part => \&cmd_generic,
|
|
cmd_privmsg => \&cmd_message,
|
|
cmd_quit => \&cmd_generic,
|
|
cmd_raw => \&cmd_raw,
|
|
cmd_sleep => \&cmd_sleep,
|
|
cmd_wait => \&cmd_wait,
|
|
# handlers for messages from IRC
|
|
irc_001 => \&irc_connected, # Welcome to ...
|
|
irc_snotice => sub {}, # notice from a server (anonymous/our uplink)
|
|
irc_notice => \&irc_notice, # NOTICE to self or channel
|
|
irc_msg => \&irc_msg, # PRIVMSG to self
|
|
irc_public => \&irc_public, # PRIVMSG to channel
|
|
irc_connected => sub {},
|
|
irc_ctcp_action => sub {},
|
|
irc_ctcp_ping => sub {},
|
|
irc_ctcp_time => sub {},
|
|
irc_ctcpreply_ping => sub {},
|
|
irc_ctcpreply_time => sub {},
|
|
irc_invite => \&irc_invite, # INVITE to channel
|
|
irc_join => sub {},
|
|
irc_kick => sub {},
|
|
irc_kill => sub {},
|
|
irc_mode => sub {},
|
|
irc_nick => sub {},
|
|
irc_part => sub {},
|
|
irc_ping => sub {},
|
|
irc_pong => sub {},
|
|
irc_rpong => sub {},
|
|
irc_quit => sub {},
|
|
irc_topic => sub {},
|
|
irc_plugin_add => sub {},
|
|
irc_error => \&irc_error,
|
|
irc_disconnected => \&irc_disconnected,
|
|
irc_socketerr => \&irc_socketerr,
|
|
},
|
|
args => [@ARGV]);
|
|
|
|
$| = 1;
|
|
$poe_kernel->run();
|
|
exit;
|
|
|
|
# Core/bookkeeping test driver functions
|
|
|
|
sub drv_start {
|
|
my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP];
|
|
|
|
# initialize heap
|
|
$heap->{clients} = {}; # session details, indexed by (short) session name
|
|
$heap->{sessions} = {}; # session details, indexed by session ref
|
|
$heap->{servers} = {}; # server addresses, indexed by short names
|
|
$heap->{macros} = {}; # macros
|
|
|
|
# Parse arguments
|
|
foreach my $arg (@_[ARG0..$#_]) {
|
|
if ($arg =~ /^-D$/) {
|
|
$heap->{irc_debug} = 1;
|
|
} elsif ($arg =~ /^-V$/) {
|
|
$heap->{verbose} = 1;
|
|
} elsif ($arg =~ /^-vhost=(.*)$/) {
|
|
$heap->{vhost} = $1;
|
|
} else {
|
|
die "Extra command-line argument $arg\n" if $heap->{script};
|
|
$heap->{script} = new FileHandle($arg, 'r')
|
|
or die "Unable to open $arg for reading: $!\n";
|
|
}
|
|
}
|
|
die "No test name specified\n" unless $heap->{script};
|
|
|
|
# hook in to POE
|
|
$kernel->alias_set('control');
|
|
$kernel->yield('heartbeat');
|
|
}
|
|
|
|
sub drv_heartbeat {
|
|
my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP];
|
|
my $script = $heap->{script};
|
|
my $used = {};
|
|
my $delay = DELAY;
|
|
|
|
while (1) {
|
|
my ($line, $lineno);
|
|
if ($heap->{line}) {
|
|
$line = delete $heap->{line};
|
|
} elsif (defined($line = <$script>)) {
|
|
$heap->{lineno} = $.;
|
|
print "." unless $heap->{irc_debug};
|
|
} else {
|
|
# close all connections
|
|
foreach my $client (values %{$heap->{clients}}) {
|
|
$kernel->call($client->{irc}, 'quit', "I fell off the end of my script");
|
|
$client->{quitting} = 1;
|
|
}
|
|
# unalias the control session
|
|
$kernel->alias_remove('control');
|
|
# die in a few seconds
|
|
$kernel->delay_set('die', 5);
|
|
return;
|
|
}
|
|
|
|
chomp $line;
|
|
# ignore comments and blank lines
|
|
next if $line =~ /^\#/ or $line !~ /\S/;
|
|
|
|
# expand any macros in the line
|
|
$line =~ s/(?<=[^\\])%(\S+?)%/$heap->{macros}->{$1}
|
|
or die "Use of undefined macro $1 at $heap->{lineno}\n"/eg;
|
|
# remove any \-escapes
|
|
$line =~ s/\\(.)/$1/g;
|
|
# figure out the type of line
|
|
if ($line =~ /^#/) {
|
|
# comment, silently ignore it
|
|
} elsif ($line =~ /^define (\S+) (.+)$/i) {
|
|
# define a new macro
|
|
$heap->{macros}->{$1} = $2;
|
|
} elsif ($line =~ /^undef (\S+)$/i) {
|
|
# remove the macro
|
|
delete $heap->{macros}->{$1};
|
|
} elsif ($line =~ /^connect (\S+) (\S+) (\S+) (\S+) :(.+)$/i) {
|
|
# connect a new session (named $1) to server $4
|
|
my ($name, $nick, $ident, $server, $userinfo, $port) = ($1, $2, $3, $4, $5, 6667);
|
|
$server = $heap->{servers}->{$server} || $server;
|
|
if ($server =~ /(.+):(\d+)/) {
|
|
$server = $1;
|
|
$port = $2;
|
|
}
|
|
die "Client with nick $nick already exists (line $heap->{lineno})" if $heap->{clients}->{$nick};
|
|
my $alias = "client_$name";
|
|
POE::Component::IRC->new($alias)
|
|
or die "Unable to create new user $nick (line $heap->{lineno}): $!";
|
|
my $client = { name => $name,
|
|
nick => $nick,
|
|
ready => 0,
|
|
expect => [],
|
|
expect_alarms => [],
|
|
irc => $kernel->alias_resolve($alias),
|
|
params => { Nick => $nick,
|
|
Server => $server,
|
|
Port => $port,
|
|
Username => $ident,
|
|
Ircname => $userinfo,
|
|
Debug => $heap->{irc_debug},
|
|
}
|
|
};
|
|
$client->params->{LocalAddr} = $heap->{vhost}
|
|
if $heap->{vhost};
|
|
$heap->{clients}->{$client->{name}} = $client;
|
|
$heap->{sessions}->{$client->{irc}} = $client;
|
|
$kernel->call($client->{irc}, 'register', 'all');
|
|
$kernel->call($client->{irc}, 'connect', $client->{params});
|
|
$used->{$name} = 1;
|
|
} elsif ($line =~ /^sync (.+)$/i) {
|
|
# do multi-way synchronization between every session named in $1
|
|
my @synced = split(/,|\s/, $1);
|
|
# first, check that they exist and are ready
|
|
foreach my $clnt (@synced) {
|
|
die "Unknown session name $clnt (line $heap->{lineno})" unless $heap->{clients}->{$clnt};
|
|
goto REDO unless $heap->{clients}->{$clnt}->{ready};
|
|
}
|
|
# next we actually send the synchronization signals
|
|
foreach my $clnt (@synced) {
|
|
my $client = $heap->{clients}->{$clnt};
|
|
$client->{sync_wait} = [map { $_ eq $clnt ? () : $heap->{clients}->{$_}->{nick} } @synced];
|
|
$kernel->call($client->{irc}, 'notice', $client->{sync_wait}, 'SYNC');
|
|
$kernel->call($session, 'disable_client', $client);
|
|
}
|
|
} elsif ($line =~ /^:(\S+) (\S+)(.*)$/i) {
|
|
# generic command handler
|
|
my ($names, $cmd, $args) = ($1, lc($2), $3);
|
|
my (@avail, @unavail);
|
|
# figure out whether each listed client is available or not
|
|
foreach my $c (split ',', $names) {
|
|
my $client = $heap->{clients}->{$c};
|
|
if (not $client) {
|
|
print "ERROR: Unknown session name $c (line $heap->{lineno}; ignoring)\n";
|
|
} elsif (($used->{$c} and not $zero_time->{$cmd}) or not $client->{ready}) {
|
|
push @unavail, $c;
|
|
} else {
|
|
push @avail, $c;
|
|
}
|
|
}
|
|
# redo command with unavailable clients
|
|
if (@unavail) {
|
|
# This will break if the command can cause a redo for
|
|
# available clients.. this should be fixed sometime
|
|
$line = ':'.join(',', @unavail).' '.$cmd.$args;
|
|
$heap->{redo} = 1;
|
|
}
|
|
# do command with available clients
|
|
if (@avail) {
|
|
# split up the argument part of the line
|
|
$args =~ /^((?:(?: [^:])|[^ ])+)?(?: :(.+))?$/;
|
|
$args = [($1 ? split(' ', $1) : ()), ($2 ? $2 : ())];
|
|
# find the client and figure out if we need to wait
|
|
foreach my $c (@avail) {
|
|
my $client = $heap->{clients}->{$c};
|
|
die "Client $c used twice as source (line $heap->{lineno})" if $used->{c} and not $zero_time->{$cmd};
|
|
$kernel->call($session, 'cmd_'.$cmd, $client, $args);
|
|
$used->{$c} = 1 unless $zero_time->{$cmd};
|
|
}
|
|
}
|
|
} else {
|
|
die "Unrecognized input line $heap->{lineno}: $line";
|
|
}
|
|
if ($heap->{redo}) {
|
|
REDO:
|
|
delete $heap->{redo};
|
|
$heap->{line} = $line;
|
|
last;
|
|
}
|
|
}
|
|
# issue new heartbeat with appropriate delay
|
|
$kernel->delay_set('heartbeat', $delay);
|
|
}
|
|
|
|
sub drv_timeout_expect {
|
|
my ($kernel, $session, $client) = @_[KERNEL, SESSION, ARG0];
|
|
print "ERROR: Dropping timed-out expectation by $client->{name}: ".join(',', @{$client->{expect}->[0]})."\n";
|
|
$client->{expect_alarms}->[0] = undef;
|
|
unexpect($kernel, $session, $client);
|
|
}
|
|
|
|
sub drv_reconnect {
|
|
my ($kernel, $session, $client) = @_[KERNEL, SESSION, ARG0];
|
|
$kernel->call($client->{irc}, 'connect', $client->{params});
|
|
}
|
|
|
|
sub drv_default {
|
|
my ($kernel, $heap, $sender, $session, $state, $args) = @_[KERNEL, HEAP, SENDER, SESSION, ARG0, ARG1];
|
|
if ($state =~ /^irc_(\d\d\d)$/) {
|
|
my $client = $heap->{sessions}->{$sender};
|
|
if (@{$client->{expect}}
|
|
and $args->[0] eq $client->{expect}->[0]->[0]
|
|
and $client->{expect}->[0]->[1] eq "$1") {
|
|
my $expect = $client->{expect}->[0];
|
|
my $mismatch;
|
|
for (my $x=2; ($x<=$#$expect) and ($x<=$#$args) and not $mismatch; $x++) {
|
|
$mismatch = 1 unless $args->[$x] =~ /$expect->[$x]/i;
|
|
}
|
|
unexpect($kernel, $session, $client) unless $mismatch;
|
|
}
|
|
return undef;
|
|
}
|
|
print "ERROR: Unexpected event $state to test driver (from ".$sender->ID.")\n"
|
|
unless $state eq '_signal';
|
|
return undef;
|
|
}
|
|
|
|
# client-based command issuers
|
|
|
|
sub cmd_message {
|
|
my ($kernel, $heap, $event, $client, $args) = @_[KERNEL, HEAP, STATE, ARG0, ARG1];
|
|
die "Missing arguments" unless $#$args >= 1;
|
|
# translate each target as appropriate (e.g. *sessionname)
|
|
my @targets = split(/,/, $args->[0]);
|
|
foreach my $target (@targets) {
|
|
if ($target =~ /^\*(.+)$/) {
|
|
my $other = $heap->{clients}->{$1} or die "Unknown session name $1 (line $heap->{lineno})\n";
|
|
$target = $other->{nick};
|
|
}
|
|
}
|
|
$kernel->call($client->{irc}, substr($event, 4), \@targets, $args->[1]);
|
|
}
|
|
|
|
sub cmd_generic {
|
|
my ($kernel, $heap, $event, $client, $args) = @_[KERNEL, HEAP, STATE, ARG0, ARG1];
|
|
$event =~ s/^cmd_//;
|
|
$kernel->call($client->{irc}, $event, @$args);
|
|
}
|
|
|
|
sub cmd_raw {
|
|
my ($kernel, $heap, $client, $args) = @_[KERNEL, HEAP, ARG0, ARG1];
|
|
die "Missing argument" unless $#$args >= 0;
|
|
$kernel->call($client->{irc}, 'sl', $args->[0]);
|
|
}
|
|
|
|
sub cmd_sleep {
|
|
my ($kernel, $session, $heap, $client, $args) = @_[KERNEL, SESSION, HEAP, ARG0, ARG1];
|
|
die "Missing argument" unless $#$args >= 0;
|
|
$kernel->call($session, 'disable_client', $client);
|
|
$kernel->delay_set('enable_client', $args->[0], $client);
|
|
}
|
|
|
|
sub cmd_wait {
|
|
my ($kernel, $session, $heap, $client, $args) = @_[KERNEL, SESSION, HEAP, ARG0, ARG1];
|
|
die "Missing argument" unless $#$args >= 0;
|
|
# if argument was comma-delimited, split it up (space-delimited is split by generic parser)
|
|
$args = [split(/,/, $args->[0])] if $args->[0] =~ /,/;
|
|
# make sure we only wait if all the other clients are ready
|
|
foreach my $other (@$args) {
|
|
if (not $heap->{clients}->{$other}->{ready}) {
|
|
$heap->{redo} = 1;
|
|
return;
|
|
}
|
|
}
|
|
# disable this client, make the others send SYNC to it
|
|
$kernel->call($session, 'disable_client', $client);
|
|
$client->{sync_wait} = [map { $heap->{clients}->{$_}->{nick} } @$args];
|
|
foreach my $other (@$args) {
|
|
die "Cannot wait on self" if $other eq $client->{name};
|
|
$kernel->call($heap->{clients}->{$other}->{irc}, 'notice', $client->{nick}, 'SYNC');
|
|
}
|
|
}
|
|
|
|
sub cmd_expect {
|
|
my ($kernel, $session, $heap, $client, $args) = @_[KERNEL, SESSION, HEAP, ARG0, ARG1];
|
|
die "Missing argument" unless $#$args >= 0;
|
|
push @{$client->{expect}}, $args;
|
|
push @{$client->{expect_alarms}}, $kernel->delay_set('timeout_expect', EXPECT_TIMEOUT, $client);
|
|
$kernel->call($session, 'disable_client', $client);
|
|
}
|
|
|
|
# handlers for messages from IRC
|
|
|
|
sub unexpect {
|
|
my ($kernel, $session, $client) = @_;
|
|
shift @{$client->{expect}};
|
|
my $alarm_id = shift @{$client->{expect_alarms}};
|
|
$kernel->alarm_remove($alarm_id) if $alarm_id;
|
|
$kernel->call($session, 'enable_client', $client) unless @{$client->{expect}};
|
|
}
|
|
|
|
sub check_expect {
|
|
my ($kernel, $session, $heap, $poe_sender, $sender, $text) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0, ARG1];
|
|
my $client = $heap->{sessions}->{$poe_sender};
|
|
my $expected = $client->{expect}->[0];
|
|
|
|
# check sender
|
|
if ($expected->[0] =~ /\*(.+)/) {
|
|
# we expect *sessionname, so look up session's current nick
|
|
my $exp = $1;
|
|
$sender =~ /^(.+)!/;
|
|
return 0 if lc($heap->{clients}->{$exp}->{nick}) ne lc($1);
|
|
} elsif ($expected->[0] =~ /^:?(.+!.+)/) {
|
|
# expect :nick!user@host, so compare whole thing
|
|
return 0 if lc($1) ne lc($sender);
|
|
} else {
|
|
# we only expect :nick, so compare that part
|
|
$sender =~ /^:?(.+)!/;
|
|
return 0 if lc($expected->[0]) ne lc($1);
|
|
}
|
|
|
|
# compare text
|
|
return 0 if lc($text) !~ /$expected->[2]/i;
|
|
|
|
# drop expectation of event
|
|
unexpect($kernel, $session, $client);
|
|
}
|
|
|
|
sub irc_connected {
|
|
my ($kernel, $session, $heap, $sender) = @_[KERNEL, SESSION, HEAP, SENDER];
|
|
my $client = $heap->{sessions}->{$sender};
|
|
print "Client $client->{name} connected to server $_[ARG0]\n" if $heap->{verbose};
|
|
$kernel->call($session, 'enable_client', $client);
|
|
}
|
|
|
|
sub irc_disconnected {
|
|
my ($kernel, $session, $heap, $sender, $server) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0];
|
|
my $client = $heap->{sessions}->{$sender};
|
|
print "Client $client->{name} disconnected from server $_[ARG0]\n" if $heap->{verbose};
|
|
if ($client->{quitting}) {
|
|
$kernel->call($sender, 'unregister', 'all');
|
|
delete $heap->{sessions}->{$sender};
|
|
delete $heap->{clients}->{$client->{name}};
|
|
} else {
|
|
if ($client->{disconnect_expected}) {
|
|
delete $client->{disconnect_expected};
|
|
} else {
|
|
print "Got unexpected disconnect for $client->{name} (nick $client->{nick})\n";
|
|
}
|
|
$kernel->call($session, 'disable_client', $client);
|
|
$kernel->delay_set('reconnect', $client->{throttled} ? THROTTLED_TIMEOUT : RECONNECT_TIMEOUT, $client);
|
|
delete $client->{throttled};
|
|
}
|
|
}
|
|
|
|
sub irc_socketerr {
|
|
my ($kernel, $session, $heap, $sender, $msg) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0];
|
|
my $client = $heap->{sessions}->{$sender};
|
|
print "Client $client->{name} (re-)connect error: $_[ARG0]\n";
|
|
if ($client->{quitting}) {
|
|
$kernel->call($sender, 'unregister', 'all');
|
|
delete $heap->{sessions}->{$sender};
|
|
delete $heap->{clients}->{$client->{name}};
|
|
} else {
|
|
if ($client->{disconnect_expected}) {
|
|
delete $client->{disconnect_expected};
|
|
} else {
|
|
print "Got unexpected disconnect for $client->{name} (nick $client->{nick})\n";
|
|
}
|
|
$kernel->call($session, 'disable_client', $client);
|
|
$kernel->delay_set('reconnect', $client->{throttled} ? THROTTLED_TIMEOUT : RECONNECT_TIMEOUT, $client);
|
|
delete $client->{throttled};
|
|
}
|
|
}
|
|
|
|
sub irc_notice {
|
|
my ($kernel, $session, $heap, $sender, $from, $to, $text) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0, ARG1, ARG2];
|
|
my $client = $heap->{sessions}->{$sender};
|
|
if ($client->{sync_wait} and $text eq 'SYNC') {
|
|
$from =~ s/!.+$//;
|
|
my $x;
|
|
# find who sent it..
|
|
for ($x=0; $x<=$#{$client->{sync_wait}}; $x++) {
|
|
last if $from eq $client->{sync_wait}->[$x];
|
|
}
|
|
# exit if we don't expect them
|
|
if ($x>$#{$client->{sync_wait}}) {
|
|
print "Got unexpected SYNC from $from to $client->{name} ($client->{nick})\n";
|
|
return;
|
|
}
|
|
# remove from the list of people we're waiting for
|
|
splice @{$client->{sync_wait}}, $x, 1;
|
|
# re-enable client if we're done waiting
|
|
if ($#{$client->{sync_wait}} == -1) {
|
|
delete $client->{sync_wait};
|
|
$kernel->call($session, 'enable_client', $client);
|
|
}
|
|
} elsif (@{$client->{expect}}
|
|
and $client->{expect}->[0]->[1] =~ /notice/i) {
|
|
check_expect(@_[0..ARG0], $text);
|
|
}
|
|
}
|
|
|
|
sub irc_msg {
|
|
my ($kernel, $session, $heap, $sender, $from, $to, $text) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0, ARG1, ARG2];
|
|
my $client = $heap->{sessions}->{$sender};
|
|
if (@{$client->{expect}}
|
|
and $client->{expect}->[0]->[1] =~ /msg/i) {
|
|
check_expect(@_[0..ARG0], $text);
|
|
}
|
|
}
|
|
|
|
sub irc_public {
|
|
my ($kernel, $session, $heap, $sender, $from, $to, $text) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0, ARG1, ARG2];
|
|
my $client = $heap->{sessions}->{$sender};
|
|
if (@{$client->{expect}}
|
|
and $client->{expect}->[0]->[1] =~ /public/i
|
|
and grep($client->{expect}->[0]->[2], @$to)) {
|
|
splice @{$client->{expect}->[0]}, 2, 1;
|
|
check_expect(@_[0..ARG0], $text);
|
|
}
|
|
}
|
|
|
|
sub irc_invite {
|
|
my ($kernel, $session, $heap, $sender, $from, $to) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0, ARG1, ARG2];
|
|
my $client = $heap->{sessions}->{$sender};
|
|
if (ref $client->{expect} eq 'ARRAY'
|
|
and $client->{expect}->[0]->[1] =~ /invite/i
|
|
and $to =~ /$client->{expect}->[0]->[2]/) {
|
|
check_expect(@_[0..ARG0], $to);
|
|
}
|
|
}
|
|
|
|
sub irc_error {
|
|
my ($kernel, $session, $heap, $sender, $what) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0];
|
|
my $client = $heap->{sessions}->{$sender};
|
|
if (@{$client->{expect}}
|
|
and $client->{expect}->[0]->[1] =~ /error/i) {
|
|
splice @{$client->{expect}->[0]}, 2, 1;
|
|
unexpect($kernel, $session, $client);
|
|
$client->{disconnect_expected} = 1;
|
|
} else {
|
|
print "ERROR: From server to $client->{name}: $what\n";
|
|
}
|
|
$client->{throttled} = 1 if $what =~ /throttled/i;
|
|
}
|