3 # If you edit this file, please check carefully that the garbage
4 # collection isn't broken. POE is sometimes too clever for our good
5 # in finding references to sessions, and keeps running even after we
13 use constant DELAY => 2;
14 use constant EXPECT_TIMEOUT => 15;
15 use constant RECONNECT_TIMEOUT => 5;
16 use constant THROTTLED_TIMEOUT => 90;
19 # sub POE::Kernel::ASSERT_DEFAULT () { 1 }
20 # sub POE::Kernel::TRACE_DEFAULT () { 1 }
22 use POE::Component::IRC v5.00;
24 # this defines commands that take "zero time" to execute
25 # (specifically, those which do not send commands from the issuing
26 # client to the server)
33 # Create the main session and start POE.
34 # All the empty anonymous subs are just to make POE:Session::ASSERT_STATES happy.
35 POE::Session->create(inline_states =>
37 # POE kernel interaction
38 _start => \&drv_start,
42 print "\nThat's all, folks!";
43 print "(exiting at line $heap->{lineno}: $heap->{line})"
47 _default => \&drv_default,
48 # generic utilities or miscellaneous functions
49 heartbeat => \&drv_heartbeat,
50 timeout_expect => \&drv_timeout_expect,
51 reconnect => \&drv_reconnect,
52 enable_client => sub { $_[ARG0]->{ready} = 1; },
53 disable_client => sub { $_[ARG0]->{ready} = 0; },
54 die => sub { $_[KERNEL]->signal($_[SESSION], 'TERM'); },
55 # client-based command issuers
56 cmd_expect => \&cmd_expect,
57 cmd_join => \&cmd_generic,
58 cmd_mode => \&cmd_generic,
59 cmd_nick => \&cmd_generic,
60 cmd_notice => \&cmd_message,
61 cmd_part => \&cmd_generic,
62 cmd_privmsg => \&cmd_message,
63 cmd_quit => \&cmd_generic,
65 cmd_sleep => \&cmd_sleep,
66 cmd_wait => \&cmd_wait,
67 # handlers for messages from IRC
68 irc_001 => \&irc_connected, # Welcome to ...
69 irc_snotice => sub {}, # notice from a server (anonymous/our uplink)
70 irc_notice => \&irc_notice, # NOTICE to self or channel
71 irc_msg => \&irc_msg, # PRIVMSG to self
72 irc_public => \&irc_public, # PRIVMSG to channel
73 irc_connected => sub {},
74 irc_ctcp_action => sub {},
75 irc_ctcp_ping => sub {},
76 irc_ctcp_time => sub {},
77 irc_ctcpreply_ping => sub {},
78 irc_ctcpreply_time => sub {},
80 irc_isupport => sub {},
84 irc_mode => \&irc_mode, # MODE change on client or channel
89 irc_registered => sub {},
91 irc_plugin_add => sub {},
92 irc_error => \&irc_error,
93 irc_disconnected => \&irc_disconnected,
94 irc_socketerr => \&irc_socketerr,
102 # Core/bookkeeping test driver functions
105 my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP];
108 $heap->{clients} = {}; # session details, indexed by (short) session name
109 $heap->{sessions} = {}; # session details, indexed by session ref
110 $heap->{servers} = {}; # server addresses, indexed by short names
111 $heap->{macros} = {}; # macros
114 foreach my $arg (@_[ARG0..$#_]) {
115 if ($arg =~ /^-D$/) {
116 $heap->{irc_debug} = 1;
117 } elsif ($arg =~ /^-V$/) {
118 $heap->{verbose} = 1;
119 } elsif ($arg =~ /^-H(.+)$/) {
120 $heap->{local_address} = $1;
122 die "Extra command-line argument $arg\n" if $heap->{script};
123 $heap->{script} = new FileHandle($arg, 'r')
124 or die "Unable to open $arg for reading: $!\n";
127 die "No test name specified\n" unless $heap->{script};
130 $kernel->alias_set('control');
131 $kernel->yield('heartbeat');
135 my ($kernel, $sender, $heap) = @_[KERNEL, SENDER, HEAP];
136 my $script = $heap->{script};
143 $line = delete $heap->{line};
144 } elsif (defined($line = <$script>)) {
145 $heap->{lineno} = $.;
146 print "." unless $heap->{irc_debug};
148 # close all connections
149 foreach my $client (values %{$heap->{clients}}) {
150 $kernel->call($client->{irc}, 'quit', "I fell off the end of my script");
151 $client->{quitting} = 1;
153 # unalias the control session
154 $kernel->alias_remove('control');
155 # die in a few seconds
156 $kernel->delay_set('die', 5);
161 # ignore comments and blank lines
162 next if $line =~ /^\#/ or $line !~ /\S/;
164 # expand any macros in the line
165 $line =~ s/(?<=[^\\])%(\S+?)%/$heap->{macros}->{$1}
166 or die "Use of undefined macro $1 at $heap->{lineno}\n"/eg;
167 # remove any \-escapes
168 $line =~ s/\\(.)/$1/g;
169 # figure out the type of line
170 if ($line =~ /^define (\S+) (.+)$/i) {
172 $heap->{macros}->{$1} = $2;
173 } elsif ($line =~ /^undef (\S+)$/i) {
175 delete $heap->{macros}->{$1};
176 } elsif ($line =~ /^connect (\S+) (\S+) (\S+) (\S+) :(.+)$/i) {
177 # connect a new session (named $1) to server $4
178 my ($name, $nick, $ident, $server, $userinfo, $port) = ($1, $2, $3, $4, $5, 6667);
179 $server = $heap->{servers}->{$server} || $server;
180 if ($server =~ /(.+):(\d+)/) {
184 die "Client with nick $nick already exists (line $heap->{lineno})" if $heap->{clients}->{$nick};
185 my $alias = "client_$name";
192 params => { Nick => $nick,
196 Ircname => $userinfo,
197 Debug => $heap->{irc_debug},
200 $client->{params}->{LocalAddr} = $heap->{local_address}
201 if $heap->{local_address};
202 my $irc = POE::Component::IRC->spawn
206 ) or die "Unable to create new user $nick (line $heap->{lineno}): $!";
207 $client->{irc} = $irc->session_id();
208 $heap->{clients}->{$client->{name}} = $client;
209 $heap->{sessions}->{$irc} = $client;
210 $kernel->call($client->{irc}, 'register', 'all');
211 $kernel->call($client->{irc}, 'connect', $client->{params});
213 } elsif ($line =~ /^sync (.+)$/i) {
214 # do multi-way synchronization between every session named in $1
215 my @synced = split(/,|\s/, $1);
216 # first, check that they exist and are ready
217 foreach my $clnt (@synced) {
218 die "Unknown session name $clnt (line $heap->{lineno})" unless $heap->{clients}->{$clnt};
219 goto REDO unless $heap->{clients}->{$clnt}->{ready};
221 # next we actually send the synchronization signals
222 foreach my $clnt (@synced) {
223 my $client = $heap->{clients}->{$clnt};
224 $client->{sync_wait} = [map { $_ eq $clnt ? () : $heap->{clients}->{$_}->{nick} } @synced];
225 $kernel->call($client->{irc}, 'notice', $client->{sync_wait}, 'SYNC');
226 $kernel->call($sender, 'disable_client', $client);
228 } elsif ($line =~ /^:(\S+) (\S+)(.*)$/i) {
229 # generic command handler
230 my ($names, $cmd, $args) = ($1, lc($2), $3);
231 my (@avail, @unavail);
232 # figure out whether each listed client is available or not
233 foreach my $c (split ',', $names) {
234 my $client = $heap->{clients}->{$c};
236 print "ERROR: Unknown session name $c (line $heap->{lineno}; ignoring)\n";
237 } elsif (($used->{$c} and not $zero_time->{$cmd}) or not $client->{ready}) {
243 # redo command with unavailable clients
245 # This will break if the command can cause a redo for
246 # available clients.. this should be fixed sometime
247 $line = ':'.join(',', @unavail).' '.$cmd.$args;
250 # do command with available clients
252 # split up the argument part of the line
253 $args =~ /^((?:(?: [^:])|[^ ])+)?(?: :(.+))?$/;
254 $args = [($1 ? split(' ', $1) : ()), ($2 ? $2 : ())];
255 # find the client and figure out if we need to wait
256 foreach my $c (@avail) {
257 my $client = $heap->{clients}->{$c};
258 die "Client $c used twice as source (line $heap->{lineno})" if $used->{c} and not $zero_time->{$cmd};
259 $kernel->call($sender, 'cmd_' . $cmd, $client, $args);
260 $used->{$c} = 1 unless $zero_time->{$cmd};
264 die "Unrecognized input line $heap->{lineno}: $line";
268 delete $heap->{redo};
269 $heap->{line} = $line;
273 # issue new heartbeat with appropriate delay
274 $kernel->delay_set('heartbeat', $delay);
277 sub drv_timeout_expect {
278 my ($kernel, $session, $client) = @_[KERNEL, SESSION, ARG0];
279 print "ERROR: Dropping timed-out expectation by $client->{name}: ".join(',', @{$client->{expect}->[0]})."\n";
280 $client->{expect_alarms}->[0] = undef;
281 unexpect($kernel, $session, $client);
285 my ($kernel, $session, $client) = @_[KERNEL, SESSION, ARG0];
286 $kernel->call($client->{irc}, 'connect', $client->{params});
290 my ($kernel, $heap, $sender, $session, $state, $args) = @_[KERNEL, HEAP, SENDER, SESSION, ARG0, ARG1];
291 if ($state =~ /^irc_(\d\d\d)$/) {
292 my $client = $heap->{sessions}->{$sender->get_heap()};
293 if (@{$client->{expect}}
294 and $args->[0] eq $client->{expect}->[0]->[0]
295 and $client->{expect}->[0]->[1] eq "$1") {
296 my $expect = $client->{expect}->[0];
298 $args = $args->[2]; # ->[1] is the entire string, ->[2] is split
299 for (my $x=2; ($x<=$#$expect) and ($x<=$#$args) and not $mismatch; $x++) {
300 if ($args->[$x] !~ /$expect->[$x]/i) {
302 print "Mismatch in arg $x: $args->[$x] !~ $expect->[$x]\n";
304 # $mismatch = 1 unless $args->[$x] =~ /$expect->[$x]/i;
306 unexpect($kernel, $session, $client) unless $mismatch;
310 print "ERROR: Unexpected event $state to test driver (from ".$sender->ID.")\n";
314 # client-based command issuers
317 my ($kernel, $heap, $event, $client, $args) = @_[KERNEL, HEAP, STATE, ARG0, ARG1];
318 die "Missing arguments" unless $#$args >= 1;
319 # translate each target as appropriate (e.g. *sessionname)
320 my @targets = split(/,/, $args->[0]);
321 foreach my $target (@targets) {
322 if ($target =~ /^\*(.+)$/) {
323 my $other = $heap->{clients}->{$1} or die "Unknown session name $1 (line $heap->{lineno})\n";
324 $target = $other->{nick};
327 $kernel->call($client->{irc}, substr($event, 4), \@targets, $args->[1]);
331 my ($kernel, $event, $client, $args) = @_[KERNEL, STATE, ARG0, ARG1];
332 $kernel->call($client->{irc}, substr($event, 4), @$args);
336 my ($kernel, $heap, $client, $args) = @_[KERNEL, HEAP, ARG0, ARG1];
337 die "Missing argument" unless $#$args >= 0;
338 $kernel->call($client->{irc}, 'sl', $args->[0]);
342 my ($kernel, $session, $heap, $client, $args) = @_[KERNEL, SESSION, HEAP, ARG0, ARG1];
343 die "Missing argument" unless $#$args >= 0;
344 $kernel->call($session, 'disable_client', $client);
345 $kernel->delay_set('enable_client', $args->[0], $client);
349 my ($kernel, $session, $heap, $client, $args) = @_[KERNEL, SESSION, HEAP, ARG0, ARG1];
350 die "Missing argument" unless $#$args >= 0;
351 # if argument was comma-delimited, split it up (space-delimited is split by generic parser)
352 $args = [split(/,/, $args->[0])] if $args->[0] =~ /,/;
353 # make sure we only wait if all the other clients are ready
354 foreach my $other (@$args) {
355 if (not $heap->{clients}->{$other}->{ready}) {
360 # disable this client, make the others send SYNC to it
361 $kernel->call($session, 'disable_client', $client);
362 $client->{sync_wait} = [map { $heap->{clients}->{$_}->{nick} } @$args];
363 foreach my $other (@$args) {
364 die "Cannot wait on self" if $other eq $client->{name};
365 $kernel->call($heap->{clients}->{$other}->{irc}, 'notice', $client->{nick}, 'SYNC');
370 my ($kernel, $session, $heap, $client, $args) = @_[KERNEL, SESSION, HEAP, ARG0, ARG1];
371 die "Missing argument" unless $#$args >= 0;
372 push @{$client->{expect}}, $args;
373 push @{$client->{expect_alarms}}, $kernel->delay_set('timeout_expect', EXPECT_TIMEOUT, $client);
374 $kernel->call($session, 'disable_client', $client);
377 # handlers for messages from IRC
380 my ($kernel, $session, $client) = @_;
381 shift @{$client->{expect}};
382 my $alarm_id = shift @{$client->{expect_alarms}};
383 $kernel->alarm_remove($alarm_id) if $alarm_id;
384 $kernel->call($session, 'enable_client', $client) unless @{$client->{expect}};
388 my ($kernel, $session, $heap, $poe_sender, $sender, $text) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0, ARG1];
389 my $client = $heap->{sessions}->{$poe_sender->get_heap()};
390 my $expected = $client->{expect}->[0];
393 if ($expected->[0] =~ /\*(.+)/) {
394 # we expect *sessionname, so look up session's current nick
397 return 0 if lc($heap->{clients}->{$exp}->{nick}) ne lc($1);
398 } elsif ($expected->[0] =~ /^:?(.+!.+)/) {
399 # expect :nick!user@host, so compare whole thing
400 return 0 if lc($1) ne lc($sender);
402 # we only expect :nick, so compare that part
403 $sender =~ /^:?(.+)!/;
404 return 0 if lc($expected->[0]) ne lc($1);
408 return 0 if lc($text) !~ /$expected->[2]/i;
410 # drop expectation of event
411 unexpect($kernel, $session, $client);
415 my ($kernel, $session, $heap, $sender) = @_[KERNEL, SESSION, HEAP, SENDER];
416 my $client = $heap->{sessions}->{$sender->get_heap()};
417 print "Client $client->{name} connected to server $_[ARG0]\n"
419 $kernel->call($session, 'enable_client', $client);
422 sub handle_irc_disconnect ($$$$$) {
423 my ($kernel, $session, $heap, $sender, $client) = @_;
424 if ($client->{quitting}) {
425 $kernel->call($sender, 'unregister', 'all');
426 delete $heap->{sessions}->{$sender->get_heap()};
427 delete $heap->{clients}->{$client->{name}};
429 if ($client->{disconnect_expected}) {
430 delete $client->{disconnect_expected};
432 print "Got unexpected disconnect for $client->{name} (nick $client->{nick})\n";
434 $kernel->call($session, 'disable_client', $client);
435 $kernel->delay_set('reconnect', $client->{throttled} ? THROTTLED_TIMEOUT : RECONNECT_TIMEOUT, $client);
436 delete $client->{throttled};
440 sub irc_disconnected {
441 my ($kernel, $session, $heap, $sender, $server) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0];
442 my $client = $heap->{sessions}->{$sender->get_heap()};
443 print "Client $client->{name} disconnected from server $_[ARG0]\n" if $heap->{verbose};
444 handle_irc_disconnect($kernel, $session, $heap, $sender, $client);
448 my ($kernel, $session, $heap, $sender, $msg) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0];
449 my $client = $heap->{sessions}->{$sender->get_heap()};
450 print "Client $client->{name} (re-)connect error: $_[ARG0]\n";
451 handle_irc_disconnect($kernel, $session, $heap, $sender, $client);
455 my ($kernel, $session, $heap, $sender, $from, $to, $text) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0, ARG1, ARG2];
456 my $client = $heap->{sessions}->{$sender->get_heap()};
457 if ($client->{sync_wait} and $text eq 'SYNC') {
461 for ($x=0; $x<=$#{$client->{sync_wait}}; $x++) {
462 last if $from eq $client->{sync_wait}->[$x];
464 # exit if we don't expect them
465 if ($x>$#{$client->{sync_wait}}) {
466 print "Got unexpected SYNC from $from to $client->{name} ($client->{nick})\n";
469 # remove from the list of people we're waiting for
470 splice @{$client->{sync_wait}}, $x, 1;
471 # re-enable client if we're done waiting
472 if ($#{$client->{sync_wait}} == -1) {
473 delete $client->{sync_wait};
474 $kernel->call($session, 'enable_client', $client);
476 } elsif (@{$client->{expect}}
477 and $client->{expect}->[0]->[1] =~ /notice/i) {
478 check_expect(@_[0..ARG0], $text);
483 my ($kernel, $session, $heap, $sender, $from, $to, $text) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0, ARG1, ARG2];
484 my $client = $heap->{sessions}->{$sender->get_heap()};
485 if (@{$client->{expect}}
486 and $client->{expect}->[0]->[1] =~ /msg/i) {
487 check_expect(@_[0..ARG0], $text);
492 my ($kernel, $session, $heap, $sender, $from, $to, $text) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0, ARG1, ARG2];
493 my $client = $heap->{sessions}->{$sender->get_heap()};
494 if (@{$client->{expect}}
495 and $client->{expect}->[0]->[1] =~ /public/i
496 and grep($client->{expect}->[0]->[2], @$to)) {
497 splice @{$client->{expect}->[0]}, 2, 1;
498 check_expect(@_[0..ARG0], $text);
503 my ($kernel, $session, $heap, $sender, $from, $to) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0, ARG1];
504 my $client = $heap->{sessions}->{$sender->get_heap()};
505 if (@{$client->{expect}}
506 and $client->{expect}->[0]->[1] =~ /mode/i
507 and grep($client->{expect}->[0]->[2], $to)) {
508 splice @{$client->{expect}->[0]}, 2, 1;
515 my ($kernel, $session, $heap, $sender, $what) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0];
516 my $client = $heap->{sessions}->{$sender->get_heap()};
517 if (@{$client->{expect}}
518 and $client->{expect}->[0]->[1] =~ /error/i) {
519 splice @{$client->{expect}->[0]}, 2, 1;
520 unexpect($kernel, $session, $client);
521 $client->{disconnect_expected} = 1;
523 print "ERROR: From server to $client->{name}: $what\n";
525 $client->{throttled} = 1 if $what =~ /throttled/i;