[irc/quakenet/snircd.git] / tests / test-driver.pl

#! /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.

require 5.006;

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;
# sub POE::Kernel::ASSERT_DEFAULT () { 1 }
# sub POE::Kernel::TRACE_DEFAULT () { 1 }
use POE v0.35;
use POE::Component::IRC v5.00;

# 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_expect => \&cmd_expect,
                      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 => sub {},
                      irc_isupport => sub {},
                      irc_join => sub {},
                      irc_kick => sub {},
                      irc_kill => sub {},
                      irc_mode => \&irc_mode, # MODE change on client or channel
                      irc_nick => sub {},
                      irc_part => sub {},
                      irc_ping => sub {},
                      irc_quit => sub {},
                      irc_registered => 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 =~ /^-H(.+)$/) {
      $heap->{local_address} = $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, $sender, $heap) = @_[KERNEL, SENDER, 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 =~ /^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";
      my $client = {
                    name => $name,
                    nick => $nick,
                    ready => 0,
                    expect => [],
                    expect_alarms => [],
                    params => { Nick     => $nick,
                                Server   => $server,
                                Port     => $port,
                                Username => $ident,
                                Ircname  => $userinfo,
                                Debug    => $heap->{irc_debug},
                              }
                   };
      $client->{params}->{LocalAddr} = $heap->{local_address}
        if $heap->{local_address};
      my $irc = POE::Component::IRC->spawn
        (
         alias => $alias,
         nick => $nick,
        ) or die "Unable to create new user $nick (line $heap->{lineno}): $!";
      $client->{irc} = $irc->session_id();
      $heap->{clients}->{$client->{name}} = $client;
      $heap->{sessions}->{$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($sender, '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($sender, '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->get_heap()};
    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;
      $args = $args->[2]; # ->[1] is the entire string, ->[2] is split
      for (my $x=2; ($x<=$#$expect) and ($x<=$#$args) and not $mismatch; $x++) {
        if ($args->[$x] !~ /$expect->[$x]/i) {
          $mismatch = 1;
          print "Mismatch in arg $x: $args->[$x] !~ $expect->[$x]\n";
        }
        # $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";
  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, $event, $client, $args) = @_[KERNEL, STATE, ARG0, ARG1];
  $kernel->call($client->{irc}, substr($event, 4), @$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->get_heap()};
  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->get_heap()};
  print "Client $client->{name} connected to server $_[ARG0]\n"
    if $heap->{verbose};
  $kernel->call($session, 'enable_client', $client);
}

sub handle_irc_disconnect ($$$$$) {
  my ($kernel, $session, $heap, $sender, $client) = @_;
  if ($client->{quitting}) {
    $kernel->call($sender, 'unregister', 'all');
    delete $heap->{sessions}->{$sender->get_heap()};
    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_disconnected {
  my ($kernel, $session, $heap, $sender, $server) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0];
  my $client = $heap->{sessions}->{$sender->get_heap()};
  print "Client $client->{name} disconnected from server $_[ARG0]\n" if $heap->{verbose};
  handle_irc_disconnect($kernel, $session, $heap, $sender, $client);
}

sub irc_socketerr {
  my ($kernel, $session, $heap, $sender, $msg) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0];
  my $client = $heap->{sessions}->{$sender->get_heap()};
  print "Client $client->{name} (re-)connect error: $_[ARG0]\n";
  handle_irc_disconnect($kernel, $session, $heap, $sender, $client);
}

sub irc_notice {
  my ($kernel, $session, $heap, $sender, $from, $to, $text) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0, ARG1, ARG2];
  my $client = $heap->{sessions}->{$sender->get_heap()};
  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->get_heap()};
  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->get_heap()};
  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_mode {
  my ($kernel, $session, $heap, $sender, $from, $to) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0, ARG1];
  my $client = $heap->{sessions}->{$sender->get_heap()};
  if (@{$client->{expect}}
      and $client->{expect}->[0]->[1] =~ /mode/i
      and grep($client->{expect}->[0]->[2], $to)) {
    splice @{$client->{expect}->[0]}, 2, 1;
    splice(@_, ARG1, 1);
    check_expect(@_);
  }
}

sub irc_error {
  my ($kernel, $session, $heap, $sender, $what) = @_[KERNEL, SESSION, HEAP, SENDER, ARG0];
  my $client = $heap->{sessions}->{$sender->get_heap()};
  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;
}
Commit	Line	Data
47528269	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	}