tests/test-driver.pl

   1 #! /usr/bin/perl -wT
   2
   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
   6 # want to stop.
   7
   8 require 5.006;
   9
  10 use warnings;
  11 use strict;
  12 use vars;
  13 use constant DELAY => 2;
  14 use constant EXPECT_TIMEOUT => 15;
  15 use constant RECONNECT_TIMEOUT => 5;
  16 use constant THROTTLED_TIMEOUT => 90;
  17
  18 use FileHandle;
  19 # sub POE::Kernel::ASSERT_DEFAULT () { 1 }
  20 # sub POE::Kernel::TRACE_DEFAULT () { 1 }
  21 use POE v0.35;
  22 use POE::Component::IRC v5.00;
  23
  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)
  27 our $zero_time = {
  28                   expect => 1,
  29                   sleep => 1,
  30                   wait => 1,
  31                  };
  32
  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 =>
  36                      {
  37                       # POE kernel interaction
  38                       _start => \&drv_start,
  39                       _child => sub {},
  40                       _stop => sub {
  41                         my $heap = $_[HEAP];
  42                         print "\nThat's all, folks!";
  43                         print "(exiting at line $heap->{lineno}: $heap->{line})"
  44                           if $heap->{line};
  45                         print "\n";
  46                       },
  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_oper => \&cmd_generic,
  62                       cmd_part => \&cmd_generic,
  63                       cmd_privmsg => \&cmd_message,
  64                       cmd_quit => \&cmd_generic,
  65                       cmd_raw => \&cmd_raw,
  66                       cmd_sleep => \&cmd_sleep,
  67                       cmd_wait => \&cmd_wait,
  68                       # handlers for messages from IRC
  69                       irc_001 => \&irc_connected, # Welcome to ...
  70                       irc_snotice => sub {}, # notice from a server (anonymous/our uplink)
  71                       irc_notice => \&irc_notice, # NOTICE to self or channel
  72                       irc_msg => \&irc_msg, # PRIVMSG to self
  73                       irc_public => \&irc_public, # PRIVMSG to channel
  74                       irc_connected => sub {},
  75                       irc_ctcp_action => sub {},
  76                       irc_ctcp_ping => sub {},
  77                       irc_ctcp_time => sub {},
  78                       irc_ctcpreply_ping => sub {},
  79                       irc_ctcpreply_time => sub {},
  80                       irc_invite => sub {},
  81                       irc_isupport => sub {},
  82                       irc_join => sub {},
  83                       irc_kick => sub {},
  84                       irc_kill => sub {},
  85                       irc_mode => \&irc_mode, # MODE change on client or channel
  86                       irc_nick => sub {},
  87                       irc_part => sub {},
  88                       irc_ping => sub {},
  89                       irc_quit => sub {},
  90                       irc_registered => sub {},
  91                       irc_topic => sub {},
  92                       irc_plugin_add => sub {},
  93                       irc_error => \&irc_error,
  94                       irc_disconnected => \&irc_disconnected,
  95                       irc_socketerr => \&irc_socketerr,
  96                      },
  97                      args => [@ARGV]);
  98
  99 $| = 1;
 100 $poe_kernel->run();
 101 exit;
 102
 103 # Core/bookkeeping test driver functions
 104
 105 sub drv_start {
 106   my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP];
 107
 108   # initialize heap
 109   $heap->{clients} = {}; # session details, indexed by (short) session name
 110   $heap->{sessions} = {}; # session details, indexed by session ref
 111   $heap->{servers} = {}; # server addresses, indexed by short names
 112   $heap->{macros} = {}; # macros
 113
 114   # Parse arguments
 115   foreach my $arg (@_[ARG0..$#_]) {
 116     if ($arg =~ /^-D$/) {
 117       $heap->{irc_debug} = 1;
 118     } elsif ($arg =~ /^-V$/) {
 119       $heap->{verbose} = 1;
 120     } elsif ($arg =~ /^-H(.+)$/) {
 121       $heap->{local_address} = $1;
 122     } else {
 123       die "Extra command-line argument $arg\n" if $heap->{script};
 124       $heap->{script} = new FileHandle($arg, 'r')
 125         or die "Unable to open $arg for reading: $!\n";
 126     }
 127   }
 128   die "No test name specified\n" unless $heap->{script};
 129
 130   # hook in to POE
 131   $kernel->alias_set('control');
 132   $kernel->yield('heartbeat');
 133 }
 134
 135 sub drv_heartbeat {
 136   my ($kernel, $sender, $heap) = @_[KERNEL, SENDER, HEAP];
 137   my $script = $heap->{script};
 138   my $used = {};
 139   my $delay = DELAY;
 140
 141   while (1) {
 142     my ($line, $lineno);
 143     if ($heap->{line}) {
 144       $line = delete $heap->{line};
 145     } elsif (defined($line = <$script>)) {
 146       $heap->{lineno} = $.;
 147       print "." unless $heap->{irc_debug};
 148     } else {
 149       # close all connections
 150       foreach my $client (values %{$heap->{clients}}) {
 151         $kernel->call($client->{irc}, 'quit', "I fell off the end of my script");
 152         $client->{quitting} = 1;
 153       }
 154       # unalias the control session
 155       $kernel->alias_remove('control');
 156       # die in a few seconds
 157       $kernel->delay_set('die', 5);
 158       return;
 159     }
 160
 161     chomp $line;
 162     # ignore comments and blank lines
 163     next if $line =~ /^\#/ or $line !~ /\S/;
 164
 165     # expand any macros in the line
 166     $line =~ s/(?<=[^\\])%(\S+?)%/$heap->{macros}->{$1}
 167       or die "Use of undefined macro $1 at $heap->{lineno}\n"/eg;
 168     # remove any \-escapes
 169     $line =~ s/\\(.)/$1/g;
 170     # figure out the type of line
 171     if ($line =~ /^define (\S+) (.+)$/i) {
 172       # define a new macro
 173       $heap->{macros}->{$1} = $2;
 174     } elsif ($line =~ /^undef (\S+)$/i) {
 175       # remove the macro
 176       delete $heap->{macros}->{$1};
 177     } elsif ($line =~ /^connect (\S+) (\S+) (\S+) (\S+) :(.+)$/i) {
 178       # connect a new session (named $1) to server $4
 179       my ($name, $nick, $ident, $server, $userinfo, $port) = ($1, $2, $3, $4, $5, 6667);
 180       $server = $heap->{servers}->{$server} || $server;
 181       if ($server =~ /(.+):(\d+)/) {
 182         $server = $1;
 183         $port = $2;
 184       }
 185       die "Client with nick $nick already exists (line $heap->{lineno})" if $heap->{clients}->{$nick};
 186       my $alias = "client_$name";
 187       my $client = {
 188                     name => $name,
 189                     nick => $nick,
 190                     ready => 0,
 191                     expect => [],
 192                     expect_alarms => [],
 193                     params => { Nick     => $nick,
 194                                 Server   => $server,
 195                                 Port     => $port,
 196                                 Username => $ident,
 197                                 Ircname  => $userinfo,
 198                                 Debug    => $heap->{irc_debug},
 199                               }
 200                    };
 201       $client->{params}->{LocalAddr} = $heap->{local_address}
 202         if $heap->{local_address};
 203       my $irc = POE::Component::IRC->spawn
 204         (
 205          alias => $alias,
 206          nick => $nick,
 207         ) or die "Unable to create new user $nick (line $heap->{lineno}): $!";
 208       $client->{irc} = $irc->session_id();
 209       $heap->{clients}->{$client->{name}} = $client;
 210       $heap->{sessions}->{$irc} = $client;
 211       $kernel->call($client->{irc}, 'register', 'all');
 212       $kernel->call($client->{irc}, 'connect', $client->{params});
 213       $used->{$name} = 1;
 214     } elsif ($line =~ /^sync (.+)$/i) {
 215       # do multi-way synchronization between every session named in $1
 216       my @synced = split(/,|\s/, $1);
 217       # first, check that they exist and are ready
 218       foreach my $clnt (@synced) {
 219         die "Unknown session name $clnt (line $heap->{lineno})" unless $heap->{clients}->{$clnt};
 220         goto REDO unless $heap->{clients}->{$clnt}->{ready};
 221       }
 222       # next we actually send the synchronization signals
 223       foreach my $clnt (@synced) {
 224         my $client = $heap->{clients}->{$clnt};
 225         $client->{sync_wait} = [map { $_ eq $clnt ? () : $heap->{clients}->{$_}->{nick} } @synced];
 226         $kernel->call($client->{irc}, 'notice', $client->{sync_wait}, 'SYNC');
 227         $kernel->call($sender, 'disable_client', $client);
 228       }
 229     } elsif ($line =~ /^:(\S+) (\S+)(.*)$/i) {
 230       # generic command handler
 231       my ($names, $cmd, $args) = ($1, lc($2), $3);
 232       my (@avail, @unavail);
 233       # figure out whether each listed client is available or not
 234       foreach my $c (split ',', $names) {
 235         my $client = $heap->{clients}->{$c};
 236         if (not $client) {
 237           print "ERROR: Unknown session name $c (line $heap->{lineno}; ignoring)\n";
 238         } elsif (($used->{$c} and not $zero_time->{$cmd}) or not $client->{ready}) {
 239           push @unavail, $c;
 240         } else {
 241           push @avail, $c;
 242         }
 243       }
 244       # redo command with unavailable clients
 245       if (@unavail) {
 246         # This will break if the command can cause a redo for
 247         # available clients.. this should be fixed sometime
 248         $line = ':'.join(',', @unavail).' '.$cmd.$args;
 249         $heap->{redo} = 1;
 250       }
 251       # do command with available clients
 252       if (@avail) {
 253         # split up the argument part of the line
 254         $args =~ /^((?:(?: [^:])|[^ ])+)?(?: :(.+))?$/;
 255         $args = [($1 ? split(' ', $1) : ()), ($2 ? $2 : ())];
 256         # find the client and figure out if we need to wait
 257         foreach my $c (@avail) {
 258           my $client = $heap->{clients}->{$c};
 259           die "Client $c used twice as source (line $heap->{lineno})" if $used->{c} and not $zero_time->{$cmd};
 260           $kernel->call($sender, 'cmd_' . $cmd, $client, $args);
 261           $used->{$c} = 1 unless $zero_time->{$cmd};
 262         }
 263       }
 264     } else {
 265       die "Unrecognized input line $heap->{lineno}: $line";
 266     }
 267     if ($heap->{redo}) {
 268     REDO:
 269       delete $heap->{redo};
 270       $heap->{line} = $line;
 271       last;
 272     }
 273   }
 274   # issue new heartbeat with appropriate delay
 275   $kernel->delay_set('heartbeat', $delay);
 276 }
 277
 278 sub drv_timeout_expect {
 279   my ($kernel, $session, $client) = @_[KERNEL, SESSION, ARG0];
 280   print "ERROR: Dropping timed-out expectation by $client->{name}: ".join(',', @{$client->{expect}->[0]})."\n";
 281   $client->{expect_alarms}->[0] = undef;
 282   unexpect($kernel, $session, $client);
 283 }
 284
 285 sub drv_reconnect {
 286   my ($kernel, $session, $client) = @_[KERNEL, SESSION, ARG0];
 287   $kernel->call($client->{irc}, 'connect', $client->{params});
 288 }
 289
 290 sub drv_default {
 291   my ($kernel, $heap, $sender, $session, $state, $args) = @_[KERNEL, HEAP, SENDER, SESSION, ARG0, ARG1];
 292   if ($state =~ /^irc_(\d\d\d)$/) {
 293     my $client = $heap->{sessions}->{$sender->get_heap()};
 294     if (@{$client->{expect}}
 295         and $args->[0] eq $client->{expect}->[0]->[0]
 296         and $client->{expect}->[0]->[1] eq "$1") {
 297       my $expect = $client->{expect}->[0];
 298       my $mismatch;
 299       $args = $args->[2]; # ->[1] is the entire string, ->[2] is split
 300       for (my $x=2; ($x<=$#$expect) and ($x<=$#$args) and not $mismatch; $x++) {
 301         if ($args->[$x] !~ /$expect->[$x]/i) {
 302           $mismatch = 1;
 303           print "Mismatch in arg $x: $args->[$x] !~ $expect->[$x]\n";
 304         }
 305         # $mismatch = 1 unless $args->[$x] =~ /$expect->[$x]/i;
 306       }
 307       unexpect($kernel, $session, $client) unless $mismatch;
 308     }
 309     return undef;
 310   }
 311   print "ERROR: Unexpected event $state to test driver (from ".$sender->ID.")\n";
 312   return undef;
 313 }
 314
 315 # client-based command issuers
 316
 317 sub cmd_message {
 318   my ($kernel, $heap, $event, $client, $args) = @_[KERNEL, HEAP, STATE, ARG0, ARG1];
 319   die "Missing arguments" unless $#$args >= 1;
 320   # translate each target as appropriate (e.g. *sessionname)
 321   my @targets = split(/,/, $args->[0]);
 322   foreach my $target (@targets) {
 323     if ($target =~ /^\*(.+)$/) {
 324       my $other = $heap->{clients}->{$1} or die "Unknown session name $1 (line $heap->{lineno})\n";
 325       $target = $other->{nick};
 326     }
 327   }
 328   $kernel->call($client->{irc}, substr($event, 4), \@targets, $args->[1]);
 329 }
 330
 331 sub cmd_generic {
 332   my ($kernel, $event, $client, $args) = @_[KERNEL, STATE, ARG0, ARG1];
 333   $kernel->call($client->{irc}, substr($event, 4), @$args);
 334 }
 335
 336 sub cmd_raw {
 337   my ($kernel, $heap, $client, $args) = @_[KERNEL, HEAP, ARG0, ARG1];
 338   die "Missing argument" unless $#$args >= 0;
 339   $kernel->call($client->{irc}, 'sl', $args->[0]);
 340 }
 341
 342 sub cmd_sleep {
 343   my ($kernel, $session, $heap, $client, $args) = @_[KERNEL, SESSION, HEAP, ARG0, ARG1];
 344   die "Missing argument" unless $#$args >= 0;
 345   $kernel->call($session, 'disable_client', $client);
 346   $kernel->delay_set('enable_client', $args->[0], $client);
 347 }
 348
 349 sub cmd_wait {
 350   my ($kernel, $session, $heap, $client, $args) = @_[KERNEL, SESSION, HEAP, ARG0, ARG1];
 351   die "Missing argument" unless $#$args >= 0;
 352   # if argument was comma-delimited, split it up (space-delimited is split by generic parser)
 353   $args = [split(/,/, $args->[0])] if $args->[0] =~ /,/;
 354   # make sure we only wait if all the other clients are ready
 355   foreach my $other (@$args) {
 356     if (not $heap->{clients}->{$other}->{ready}) {
 357       $heap->{redo} = 1;
 358       return;
 359     }
 360   }
 361   # disable this client, make the others send SYNC to it
 362   $kernel->call($session, 'disable_client', $client);
 363   $client->{sync_wait} = [map { $heap->{clients}->{$_}->{nick} } @$args];
 364   foreach my $other (@$args) {
 365     die "Cannot wait on self" if $other eq $client->{name};
 366     $kernel->call($heap->{clients}->{$other}->{irc}, 'notice', $client->{nick}, 'SYNC');
 367   }
 368 }
 369
 370 sub cmd_expect {
 371   my ($kernel, $session, $heap, $client, $args) = @_[KERNEL, SESSION, HEAP, ARG0, ARG1];
 372   die "Missing argument" unless $#$args >= 0;
 373   push @{$client->{expect}}, $args;
 374   push @{$client->{expect_alarms}}, $kernel->delay_set('timeout_expect', EXPECT_TIMEOUT, $client);
 375   $kernel->call($session, 'disable_client', $client);
 376 }
 377
 378 # handlers for messages from IRC
 379
 380 sub unexpect {
 381   my ($kernel, $session, $client) = @_;
 382   shift @{$client->{expect}};
 383   my $alarm_id = shift @{$client->{expect_alarms}};
 384   $kernel->alarm_remove($alarm_id) if $alarm_id;
 385   $kernel->call($session, 'enable_client', $client) unless @{$client->{expect}};
 386 }
 387
 388 sub check_expect {
 389   my ($kernel, $session, $heap, $poe_sender, $sender, $text) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0, ARG1];
 390   my $client = $heap->{sessions}->{$poe_sender->get_heap()};
 391   my $expected = $client->{expect}->[0];
 392
 393   # check sender
 394   if ($expected->[0] =~ /\*(.+)/) {
 395     # we expect *sessionname, so look up session's current nick
 396     my $exp = $1;
 397     $sender =~ /^(.+)!/;
 398     return 0 if lc($heap->{clients}->{$exp}->{nick}) ne lc($1);
 399   } elsif ($expected->[0] =~ /^:?(.+!.+)/) {
 400     # expect :nick!user@host, so compare whole thing
 401     return 0 if lc($1) ne lc($sender);
 402   } else {
 403     # we only expect :nick, so compare that part
 404     $sender =~ /^:?(.+)!/;
 405     return 0 if lc($expected->[0]) ne lc($1);
 406   }
 407
 408   # compare text
 409   return 0 if lc($text) !~ /$expected->[2]/i;
 410
 411   # drop expectation of event
 412   unexpect($kernel, $session, $client);
 413 }
 414
 415 sub irc_connected {
 416   my ($kernel, $session, $heap, $sender) = @_[KERNEL, SESSION, HEAP, SENDER];
 417   my $client = $heap->{sessions}->{$sender->get_heap()};
 418   print "Client $client->{name} connected to server $_[ARG0]\n"
 419     if $heap->{verbose};
 420   $kernel->call($session, 'enable_client', $client);
 421 }
 422
 423 sub handle_irc_disconnect ($$$$$) {
 424   my ($kernel, $session, $heap, $sender, $client) = @_;
 425   if ($client->{quitting}) {
 426     $kernel->call($sender, 'unregister', 'all');
 427     delete $heap->{sessions}->{$sender->get_heap()};
 428     delete $heap->{clients}->{$client->{name}};
 429   } else {
 430     if ($client->{disconnect_expected}) {
 431       delete $client->{disconnect_expected};
 432     } else {
 433       print "Got unexpected disconnect for $client->{name} (nick $client->{nick})\n";
 434     }
 435     $kernel->call($session, 'disable_client', $client);
 436     $kernel->delay_set('reconnect', $client->{throttled} ? THROTTLED_TIMEOUT : RECONNECT_TIMEOUT, $client);
 437     delete $client->{throttled};
 438   }
 439 }
 440
 441 sub irc_disconnected {
 442   my ($kernel, $session, $heap, $sender, $server) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0];
 443   my $client = $heap->{sessions}->{$sender->get_heap()};
 444   print "Client $client->{name} disconnected from server $_[ARG0]\n" if $heap->{verbose};
 445   handle_irc_disconnect($kernel, $session, $heap, $sender, $client);
 446 }
 447
 448 sub irc_socketerr {
 449   my ($kernel, $session, $heap, $sender, $msg) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0];
 450   my $client = $heap->{sessions}->{$sender->get_heap()};
 451   print "Client $client->{name} (re-)connect error: $_[ARG0]\n";
 452   handle_irc_disconnect($kernel, $session, $heap, $sender, $client);
 453 }
 454
 455 sub irc_notice {
 456   my ($kernel, $session, $heap, $sender, $from, $to, $text) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0, ARG1, ARG2];
 457   my $client = $heap->{sessions}->{$sender->get_heap()};
 458   if ($client->{sync_wait} and $text eq 'SYNC') {
 459     $from =~ s/!.+$//;
 460     my $x;
 461     # find who sent it..
 462     for ($x=0; $x<=$#{$client->{sync_wait}}; $x++) {
 463       last if $from eq $client->{sync_wait}->[$x];
 464     }
 465     # exit if we don't expect them
 466     if ($x>$#{$client->{sync_wait}}) {
 467       print "Got unexpected SYNC from $from to $client->{name} ($client->{nick})\n";
 468       return;
 469     }
 470     # remove from the list of people we're waiting for
 471     splice @{$client->{sync_wait}}, $x, 1;
 472     # re-enable client if we're done waiting
 473     if ($#{$client->{sync_wait}} == -1) {
 474       delete $client->{sync_wait};
 475       $kernel->call($session, 'enable_client', $client);
 476     }
 477   } elsif (@{$client->{expect}}
 478            and $client->{expect}->[0]->[1] =~ /notice/i) {
 479     check_expect(@_[0..ARG0], $text);
 480   }
 481 }
 482
 483 sub irc_msg {
 484   my ($kernel, $session, $heap, $sender, $from, $to, $text) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0, ARG1, ARG2];
 485   my $client = $heap->{sessions}->{$sender->get_heap()};
 486   if (@{$client->{expect}}
 487       and $client->{expect}->[0]->[1] =~ /msg/i) {
 488     check_expect(@_[0..ARG0], $text);
 489   }
 490 }
 491
 492 sub irc_public {
 493   my ($kernel, $session, $heap, $sender, $from, $to, $text) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0, ARG1, ARG2];
 494   my $client = $heap->{sessions}->{$sender->get_heap()};
 495   if (@{$client->{expect}}
 496       and $client->{expect}->[0]->[1] =~ /public/i
 497       and grep($client->{expect}->[0]->[2], @$to)) {
 498     splice @{$client->{expect}->[0]}, 2, 1;
 499     check_expect(@_[0..ARG0], $text);
 500   }
 501 }
 502
 503 sub irc_mode {
 504   my ($kernel, $session, $heap, $sender, $from, $to) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0, ARG1];
 505   my $client = $heap->{sessions}->{$sender->get_heap()};
 506   if (@{$client->{expect}}
 507       and $client->{expect}->[0]->[1] =~ /mode/i
 508       and grep($client->{expect}->[0]->[2], $to)) {
 509     splice @{$client->{expect}->[0]}, 2, 1;
 510     splice(@_, ARG1, 1);
 511     check_expect(@_);
 512   }
 513 }
 514
 515 sub irc_error {
 516   my ($kernel, $session, $heap, $sender, $what) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0];
 517   my $client = $heap->{sessions}->{$sender->get_heap()};
 518   if (@{$client->{expect}}
 519       and $client->{expect}->[0]->[1] =~ /error/i) {
 520     splice @{$client->{expect}->[0]}, 2, 1;
 521     unexpect($kernel, $session, $client);
 522     $client->{disconnect_expected} = 1;
 523   } else {
 524     print "ERROR: From server to $client->{name}: $what\n";
 525   }
 526   $client->{throttled} = 1 if $what =~ /throttled/i;
 527 }