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
9 # This interprets a simple scripting language. Lines starting with a
10 # hash mark (#, aka octothorpe, pound sign, etc) are ignored. The
11 # special commands look like this, where angle brackets indicate a
13 # define <macro> <value>
15 # connect <name> <nick> <ident> <server> :<userinfo>
16 # sync <name1>,<name2>[,<name3>]*
17 # :<name> <command>[ <args]*
18 # For the last line syntax, <command> may be an IRC or IRC-like
19 # command. Supported non-IRC commands are:
20 # :<name> expect <source|*name2> [...]
22 # :<name> sleep <seconds>
23 # :<name> wait <name2>
31 use constant DELAY => 2;
32 use constant EXPECT_TIMEOUT => 15;
33 use constant RECONNECT_TIMEOUT => 5;
34 use constant THROTTLED_TIMEOUT => 90;
38 use POE::Component::IRC;
40 # this defines commands that take "zero time" to execute
41 # (specifically, those which do not send commands from the issuing
42 # client to the server)
49 # Create the main session and start POE.
50 # All the empty anonymous subs are just to make POE:Session::ASSERT_STATES happy.
51 POE::Session->create(inline_states =>
53 # POE kernel interaction
54 _start => \&drv_start,
58 print "\nThat's all, folks!";
59 print "(exiting at line $heap->{lineno}: $heap->{line})"
63 _default => \&drv_default,
64 # generic utilities or miscellaneous functions
65 heartbeat => \&drv_heartbeat,
66 timeout_expect => \&drv_timeout_expect,
67 reconnect => \&drv_reconnect,
68 enable_client => sub { $_[ARG0]->{ready} = 1; },
69 disable_client => sub { $_[ARG0]->{ready} = 0; },
70 die => sub { $_[KERNEL]->signal($_[SESSION], 'TERM'); },
71 # client-based command issuers
72 cmd_die => \&cmd_generic,
73 cmd_expect => \&cmd_expect,
74 cmd_invite => \&cmd_generic,
75 cmd_join => \&cmd_generic,
76 cmd_mode => \&cmd_generic,
77 cmd_nick => \&cmd_generic,
78 cmd_notice => \&cmd_message,
79 cmd_oper => \&cmd_generic,
80 cmd_part => \&cmd_generic,
81 cmd_privmsg => \&cmd_message,
82 cmd_quit => \&cmd_generic,
84 cmd_sleep => \&cmd_sleep,
85 cmd_wait => \&cmd_wait,
86 # handlers for messages from IRC
87 irc_001 => \&irc_connected, # Welcome to ...
88 irc_snotice => sub {}, # notice from a server (anonymous/our uplink)
89 irc_notice => \&irc_notice, # NOTICE to self or channel
90 irc_msg => \&irc_msg, # PRIVMSG to self
91 irc_public => \&irc_public, # PRIVMSG to channel
92 irc_connected => sub {},
93 irc_ctcp_action => sub {},
94 irc_ctcp_ping => sub {},
95 irc_ctcp_time => sub {},
96 irc_ctcpreply_ping => sub {},
97 irc_ctcpreply_time => sub {},
98 irc_invite => \&irc_invite, # INVITE to channel
110 irc_plugin_add => sub {},
111 irc_error => \&irc_error,
112 irc_disconnected => \&irc_disconnected,
113 irc_socketerr => \&irc_socketerr,
121 # Core/bookkeeping test driver functions
124 my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP];
127 $heap->{clients} = {}; # session details, indexed by (short) session name
128 $heap->{sessions} = {}; # session details, indexed by session ref
129 $heap->{servers} = {}; # server addresses, indexed by short names
130 $heap->{macros} = {}; # macros
133 foreach my $arg (@_[ARG0..$#_]) {
134 if ($arg =~ /^-D$/) {
135 $heap->{irc_debug} = 1;
136 } elsif ($arg =~ /^-V$/) {
137 $heap->{verbose} = 1;
138 } elsif ($arg =~ /^-vhost=(.*)$/) {
141 die "Extra command-line argument $arg\n" if $heap->{script};
142 $heap->{script} = new FileHandle($arg, 'r')
143 or die "Unable to open $arg for reading: $!\n";
146 die "No test name specified\n" unless $heap->{script};
149 $kernel->alias_set('control');
150 $kernel->yield('heartbeat');
154 my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP];
155 my $script = $heap->{script};
162 $line = delete $heap->{line};
163 } elsif (defined($line = <$script>)) {
164 $heap->{lineno} = $.;
165 print "." unless $heap->{irc_debug};
167 # close all connections
168 foreach my $client (values %{$heap->{clients}}) {
169 $kernel->call($client->{irc}, 'quit', "I fell off the end of my script");
170 $client->{quitting} = 1;
172 # unalias the control session
173 $kernel->alias_remove('control');
174 # die in a few seconds
175 $kernel->delay_set('die', 5);
180 # ignore comments and blank lines
181 next if $line =~ /^\#/ or $line !~ /\S/;
183 # expand any macros in the line
184 $line =~ s/(?<=[^\\])%(\S+?)%/$heap->{macros}->{$1}
185 or die "Use of undefined macro $1 at $heap->{lineno}\n"/eg;
186 # remove any \-escapes
187 $line =~ s/\\(.)/$1/g;
188 # figure out the type of line
190 # comment, silently ignore it
191 } elsif ($line =~ /^define (\S+) (.+)$/i) {
193 $heap->{macros}->{$1} = $2;
194 } elsif ($line =~ /^undef (\S+)$/i) {
196 delete $heap->{macros}->{$1};
197 } elsif ($line =~ /^connect (\S+) (\S+) (\S+) (\S+) :(.+)$/i) {
198 # connect a new session (named $1) to server $4
199 my ($name, $nick, $ident, $server, $userinfo, $port) = ($1, $2, $3, $4, $5, 6667);
200 $server = $heap->{servers}->{$server} || $server;
201 if ($server =~ /(.+):(\d+)/) {
205 die "Client with nick $nick already exists (line $heap->{lineno})" if $heap->{clients}->{$nick};
206 my $alias = "client_$name";
207 POE::Component::IRC->new($alias)
208 or die "Unable to create new user $nick (line $heap->{lineno}): $!";
209 my $client = { name => $name,
214 irc => $kernel->alias_resolve($alias),
215 params => { Nick => $nick,
219 Ircname => $userinfo,
220 Debug => $heap->{irc_debug},
223 $client->params->{LocalAddr} = $heap->{vhost}
225 $heap->{clients}->{$client->{name}} = $client;
226 $heap->{sessions}->{$client->{irc}} = $client;
227 $kernel->call($client->{irc}, 'register', 'all');
228 $kernel->call($client->{irc}, 'connect', $client->{params});
230 } elsif ($line =~ /^sync (.+)$/i) {
231 # do multi-way synchronization between every session named in $1
232 my @synced = split(/,|\s/, $1);
233 # first, check that they exist and are ready
234 foreach my $clnt (@synced) {
235 die "Unknown session name $clnt (line $heap->{lineno})" unless $heap->{clients}->{$clnt};
236 goto REDO unless $heap->{clients}->{$clnt}->{ready};
238 # next we actually send the synchronization signals
239 foreach my $clnt (@synced) {
240 my $client = $heap->{clients}->{$clnt};
241 $client->{sync_wait} = [map { $_ eq $clnt ? () : $heap->{clients}->{$_}->{nick} } @synced];
242 $kernel->call($client->{irc}, 'notice', $client->{sync_wait}, 'SYNC');
243 $kernel->call($session, 'disable_client', $client);
245 } elsif ($line =~ /^:(\S+) (\S+)(.*)$/i) {
246 # generic command handler
247 my ($names, $cmd, $args) = ($1, lc($2), $3);
248 my (@avail, @unavail);
249 # figure out whether each listed client is available or not
250 foreach my $c (split ',', $names) {
251 my $client = $heap->{clients}->{$c};
253 print "ERROR: Unknown session name $c (line $heap->{lineno}; ignoring)\n";
254 } elsif (($used->{$c} and not $zero_time->{$cmd}) or not $client->{ready}) {
260 # redo command with unavailable clients
262 # This will break if the command can cause a redo for
263 # available clients.. this should be fixed sometime
264 $line = ':'.join(',', @unavail).' '.$cmd.$args;
267 # do command with available clients
269 # split up the argument part of the line
270 $args =~ /^((?:(?: [^:])|[^ ])+)?(?: :(.+))?$/;
271 $args = [($1 ? split(' ', $1) : ()), ($2 ? $2 : ())];
272 # find the client and figure out if we need to wait
273 foreach my $c (@avail) {
274 my $client = $heap->{clients}->{$c};
275 die "Client $c used twice as source (line $heap->{lineno})" if $used->{c} and not $zero_time->{$cmd};
276 $kernel->call($session, 'cmd_'.$cmd, $client, $args);
277 $used->{$c} = 1 unless $zero_time->{$cmd};
281 die "Unrecognized input line $heap->{lineno}: $line";
285 delete $heap->{redo};
286 $heap->{line} = $line;
290 # issue new heartbeat with appropriate delay
291 $kernel->delay_set('heartbeat', $delay);
294 sub drv_timeout_expect {
295 my ($kernel, $session, $client) = @_[KERNEL, SESSION, ARG0];
296 print "ERROR: Dropping timed-out expectation by $client->{name}: ".join(',', @{$client->{expect}->[0]})."\n";
297 $client->{expect_alarms}->[0] = undef;
298 unexpect($kernel, $session, $client);
302 my ($kernel, $session, $client) = @_[KERNEL, SESSION, ARG0];
303 $kernel->call($client->{irc}, 'connect', $client->{params});
307 my ($kernel, $heap, $sender, $session, $state, $args) = @_[KERNEL, HEAP, SENDER, SESSION, ARG0, ARG1];
308 if ($state =~ /^irc_(\d\d\d)$/) {
309 my $client = $heap->{sessions}->{$sender};
310 if (@{$client->{expect}}
311 and $args->[0] eq $client->{expect}->[0]->[0]
312 and $client->{expect}->[0]->[1] eq "$1") {
313 my $expect = $client->{expect}->[0];
315 for (my $x=2; ($x<=$#$expect) and ($x<=$#$args) and not $mismatch; $x++) {
316 $mismatch = 1 unless $args->[$x] =~ /$expect->[$x]/i;
318 unexpect($kernel, $session, $client) unless $mismatch;
322 print "ERROR: Unexpected event $state to test driver (from ".$sender->ID.")\n"
323 unless $state eq '_signal';
327 # client-based command issuers
330 my ($kernel, $heap, $event, $client, $args) = @_[KERNEL, HEAP, STATE, ARG0, ARG1];
331 die "Missing arguments" unless $#$args >= 1;
332 # translate each target as appropriate (e.g. *sessionname)
333 my @targets = split(/,/, $args->[0]);
334 foreach my $target (@targets) {
335 if ($target =~ /^\*(.+)$/) {
336 my $other = $heap->{clients}->{$1} or die "Unknown session name $1 (line $heap->{lineno})\n";
337 $target = $other->{nick};
340 $kernel->call($client->{irc}, substr($event, 4), \@targets, $args->[1]);
344 my ($kernel, $heap, $event, $client, $args) = @_[KERNEL, HEAP, STATE, ARG0, ARG1];
346 $kernel->call($client->{irc}, $event, @$args);
350 my ($kernel, $heap, $client, $args) = @_[KERNEL, HEAP, ARG0, ARG1];
351 die "Missing argument" unless $#$args >= 0;
352 $kernel->call($client->{irc}, 'sl', $args->[0]);
356 my ($kernel, $session, $heap, $client, $args) = @_[KERNEL, SESSION, HEAP, ARG0, ARG1];
357 die "Missing argument" unless $#$args >= 0;
358 $kernel->call($session, 'disable_client', $client);
359 $kernel->delay_set('enable_client', $args->[0], $client);
363 my ($kernel, $session, $heap, $client, $args) = @_[KERNEL, SESSION, HEAP, ARG0, ARG1];
364 die "Missing argument" unless $#$args >= 0;
365 # if argument was comma-delimited, split it up (space-delimited is split by generic parser)
366 $args = [split(/,/, $args->[0])] if $args->[0] =~ /,/;
367 # make sure we only wait if all the other clients are ready
368 foreach my $other (@$args) {
369 if (not $heap->{clients}->{$other}->{ready}) {
374 # disable this client, make the others send SYNC to it
375 $kernel->call($session, 'disable_client', $client);
376 $client->{sync_wait} = [map { $heap->{clients}->{$_}->{nick} } @$args];
377 foreach my $other (@$args) {
378 die "Cannot wait on self" if $other eq $client->{name};
379 $kernel->call($heap->{clients}->{$other}->{irc}, 'notice', $client->{nick}, 'SYNC');
384 my ($kernel, $session, $heap, $client, $args) = @_[KERNEL, SESSION, HEAP, ARG0, ARG1];
385 die "Missing argument" unless $#$args >= 0;
386 push @{$client->{expect}}, $args;
387 push @{$client->{expect_alarms}}, $kernel->delay_set('timeout_expect', EXPECT_TIMEOUT, $client);
388 $kernel->call($session, 'disable_client', $client);
391 # handlers for messages from IRC
394 my ($kernel, $session, $client) = @_;
395 shift @{$client->{expect}};
396 my $alarm_id = shift @{$client->{expect_alarms}};
397 $kernel->alarm_remove($alarm_id) if $alarm_id;
398 $kernel->call($session, 'enable_client', $client) unless @{$client->{expect}};
402 my ($kernel, $session, $heap, $poe_sender, $sender, $text) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0, ARG1];
403 my $client = $heap->{sessions}->{$poe_sender};
404 my $expected = $client->{expect}->[0];
407 if ($expected->[0] =~ /\*(.+)/) {
408 # we expect *sessionname, so look up session's current nick
411 return 0 if lc($heap->{clients}->{$exp}->{nick}) ne lc($1);
412 } elsif ($expected->[0] =~ /^:?(.+!.+)/) {
413 # expect :nick!user@host, so compare whole thing
414 return 0 if lc($1) ne lc($sender);
416 # we only expect :nick, so compare that part
417 $sender =~ /^:?(.+)!/;
418 return 0 if lc($expected->[0]) ne lc($1);
422 return 0 if lc($text) !~ /$expected->[2]/i;
424 # drop expectation of event
425 unexpect($kernel, $session, $client);
429 my ($kernel, $session, $heap, $sender) = @_[KERNEL, SESSION, HEAP, SENDER];
430 my $client = $heap->{sessions}->{$sender};
431 print "Client $client->{name} connected to server $_[ARG0]\n" if $heap->{verbose};
432 $kernel->call($session, 'enable_client', $client);
435 sub irc_disconnected {
436 my ($kernel, $session, $heap, $sender, $server) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0];
437 my $client = $heap->{sessions}->{$sender};
438 print "Client $client->{name} disconnected from server $_[ARG0]\n" if $heap->{verbose};
439 if ($client->{quitting}) {
440 $kernel->call($sender, 'unregister', 'all');
441 delete $heap->{sessions}->{$sender};
442 delete $heap->{clients}->{$client->{name}};
444 if ($client->{disconnect_expected}) {
445 delete $client->{disconnect_expected};
447 print "Got unexpected disconnect for $client->{name} (nick $client->{nick})\n";
449 $kernel->call($session, 'disable_client', $client);
450 $kernel->delay_set('reconnect', $client->{throttled} ? THROTTLED_TIMEOUT : RECONNECT_TIMEOUT, $client);
451 delete $client->{throttled};
456 my ($kernel, $session, $heap, $sender, $msg) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0];
457 my $client = $heap->{sessions}->{$sender};
458 print "Client $client->{name} (re-)connect error: $_[ARG0]\n";
459 if ($client->{quitting}) {
460 $kernel->call($sender, 'unregister', 'all');
461 delete $heap->{sessions}->{$sender};
462 delete $heap->{clients}->{$client->{name}};
464 if ($client->{disconnect_expected}) {
465 delete $client->{disconnect_expected};
467 print "Got unexpected disconnect for $client->{name} (nick $client->{nick})\n";
469 $kernel->call($session, 'disable_client', $client);
470 $kernel->delay_set('reconnect', $client->{throttled} ? THROTTLED_TIMEOUT : RECONNECT_TIMEOUT, $client);
471 delete $client->{throttled};
476 my ($kernel, $session, $heap, $sender, $from, $to, $text) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0, ARG1, ARG2];
477 my $client = $heap->{sessions}->{$sender};
478 if ($client->{sync_wait} and $text eq 'SYNC') {
482 for ($x=0; $x<=$#{$client->{sync_wait}}; $x++) {
483 last if $from eq $client->{sync_wait}->[$x];
485 # exit if we don't expect them
486 if ($x>$#{$client->{sync_wait}}) {
487 print "Got unexpected SYNC from $from to $client->{name} ($client->{nick})\n";
490 # remove from the list of people we're waiting for
491 splice @{$client->{sync_wait}}, $x, 1;
492 # re-enable client if we're done waiting
493 if ($#{$client->{sync_wait}} == -1) {
494 delete $client->{sync_wait};
495 $kernel->call($session, 'enable_client', $client);
497 } elsif (@{$client->{expect}}
498 and $client->{expect}->[0]->[1] =~ /notice/i) {
499 check_expect(@_[0..ARG0], $text);
504 my ($kernel, $session, $heap, $sender, $from, $to, $text) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0, ARG1, ARG2];
505 my $client = $heap->{sessions}->{$sender};
506 if (@{$client->{expect}}
507 and $client->{expect}->[0]->[1] =~ /msg/i) {
508 check_expect(@_[0..ARG0], $text);
513 my ($kernel, $session, $heap, $sender, $from, $to, $text) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0, ARG1, ARG2];
514 my $client = $heap->{sessions}->{$sender};
515 if (@{$client->{expect}}
516 and $client->{expect}->[0]->[1] =~ /public/i
517 and grep($client->{expect}->[0]->[2], @$to)) {
518 splice @{$client->{expect}->[0]}, 2, 1;
519 check_expect(@_[0..ARG0], $text);
524 my ($kernel, $session, $heap, $sender, $from, $to) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0, ARG1, ARG2];
525 my $client = $heap->{sessions}->{$sender};
526 if (ref $client->{expect} eq 'ARRAY'
527 and $client->{expect}->[0]->[1] =~ /invite/i
528 and $to =~ /$client->{expect}->[0]->[2]/) {
529 check_expect(@_[0..ARG0], $to);
534 my ($kernel, $session, $heap, $sender, $what) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0];
535 my $client = $heap->{sessions}->{$sender};
536 if (@{$client->{expect}}
537 and $client->{expect}->[0]->[1] =~ /error/i) {
538 splice @{$client->{expect}->[0]}, 2, 1;
539 unexpect($kernel, $session, $client);
540 $client->{disconnect_expected} = 1;
542 print "ERROR: From server to $client->{name}: $what\n";
544 $client->{throttled} = 1 if $what =~ /throttled/i;