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