]>
jfr.im git - irc/evilnet/x3.git/blob - tests/test-driver.pl
3 # If you edit this file, please check carefully that the garbage
4 # collection isn't broken. POE is sometimes too clever for our good
5 # in finding references to sessions, and keeps running even after we
13 use constant DELAY
=> 2;
14 use constant EXPECT_TIMEOUT
=> 15;
15 use constant RECONNECT_TIMEOUT
=> 5;
16 use constant THROTTLED_TIMEOUT
=> 90;
20 use POE
::Component
::IRC
;
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)
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
=>
35 # POE kernel interaction
36 _start
=> \
&drv_start
,
40 print "\nThat's all, folks!";
41 print "(exiting at line $heap->{lineno}: $heap->{line})"
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
,
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 {},
87 irc_error
=> \
&irc_error
,
88 irc_disconnected
=> \
&irc_disconnected
,
89 irc_socketerr
=> \
&irc_socketerr
,
97 # Core/bookkeeping test driver functions
100 my ($kernel, $session, $heap) = @_[KERNEL
, SESSION
, HEAP
];
103 $heap->{clients
} = {}; # session details, indexed by (short) session name
104 $heap->{sessions
} = {}; # session details, indexed by session ref
105 $heap->{servers
} = {}; # server addresses, indexed by short names
106 $heap->{macros
} = {}; # macros
109 foreach my $arg (@_[ARG0
..$#_]) {
110 if ($arg =~ /^-D$/) {
111 $heap->{irc_debug
} = 1;
112 } elsif ($arg =~ /^-V$/) {
113 $heap->{verbose
} = 1;
115 die "Extra command-line argument $arg\n" if $heap->{script
};
116 $heap->{script
} = new FileHandle
($arg, 'r')
117 or die "Unable to open $arg for reading: $!\n";
120 die "No test name specified\n" unless $heap->{script
};
123 $kernel->alias_set('control');
124 $kernel->yield('heartbeat');
128 my ($kernel, $session, $heap) = @_[KERNEL
, SESSION
, HEAP
];
129 my $script = $heap->{script
};
136 $line = delete $heap->{line
};
137 } elsif (defined($line = <$script>)) {
138 $heap->{lineno
} = $.;
139 print "." unless $heap->{irc_debug
};
141 # close all connections
142 foreach my $client (values %{$heap->{clients
}}) {
143 $kernel->call($client->{irc
}, 'quit', "I fell off the end of my script");
144 $client->{quitting
} = 1;
146 # unalias the control session
147 $kernel->alias_remove('control');
148 # die in a few seconds
149 $kernel->delay_set('die', 5);
154 # ignore comments and blank lines
155 next if $line =~ /^\#/ or $line !~ /\S/;
157 # expand any macros in the line
158 $line =~ s
/(?<=[^\\])%(\S+?)%/$heap
->{macros
}->{$1}
159 or die "Use of undefined macro $1 at $heap->{lineno}\n"/eg
;
160 # remove any \-escapes
161 $line =~ s/\\(.)/$1/g;
162 # figure out the type of line
163 if ($line =~ /^define (\S+) (.+)$/i) {
165 $heap->{macros
}->{$1} = $2;
166 } elsif ($line =~ /^undef (\S+)$/i) {
168 delete $heap->{macros
}->{$1};
169 } elsif ($line =~ /^connect (\S+) (\S+) (\S+) (\S+) :(.+)$/i) {
170 # connect a new session (named $1) to server $4
171 my ($name, $nick, $ident, $server, $userinfo, $port) = ($1, $2, $3, $4, $5, 6667);
172 $server = $heap->{servers
}->{$server} || $server;
173 if ($server =~ /(.+):(\d+)/) {
177 die "Client with nick $nick already exists (line $heap->{lineno})" if $heap->{clients
}->{$nick};
178 my $alias = "client_$name";
179 POE
::Component
::IRC-
>new($alias)
180 or die "Unable to create new user $nick (line $heap->{lineno}): $!";
181 my $client = { name
=> $name,
186 irc
=> $kernel->alias_resolve($alias),
187 params
=> { Nick
=> $nick,
191 Ircname
=> $userinfo,
192 Debug
=> $heap->{irc_debug
},
195 $heap->{clients
}->{$client->{name
}} = $client;
196 $heap->{sessions
}->{$client->{irc
}} = $client;
197 $kernel->call($client->{irc
}, 'register', 'all');
198 $kernel->call($client->{irc
}, 'connect', $client->{params
});
200 } elsif ($line =~ /^sync (.+)$/i) {
201 # do multi-way synchronization between every session named in $1
202 my @synced = split(/,|\s/, $1);
203 # first, check that they exist and are ready
204 foreach my $clnt (@synced) {
205 die "Unknown session name $clnt (line $heap->{lineno})" unless $heap->{clients
}->{$clnt};
206 goto REDO
unless $heap->{clients
}->{$clnt}->{ready
};
208 # next we actually send the synchronization signals
209 foreach my $clnt (@synced) {
210 my $client = $heap->{clients
}->{$clnt};
211 $client->{sync_wait
} = [map { $_ eq $clnt ? () : $heap->{clients
}->{$_}->{nick
} } @synced];
212 $kernel->call($client->{irc
}, 'notice', $client->{sync_wait
}, 'SYNC');
213 $kernel->call($session, 'disable_client', $client);
215 } elsif ($line =~ /^:(\S+) (\S+)(.*)$/i) {
216 # generic command handler
217 my ($names, $cmd, $args) = ($1, lc($2), $3);
218 my (@avail, @unavail);
219 # figure out whether each listed client is available or not
220 foreach my $c (split ',', $names) {
221 my $client = $heap->{clients
}->{$c};
223 print "ERROR: Unknown session name $c (line $heap->{lineno}; ignoring)\n";
224 } elsif (($used->{$c} and not $zero_time->{$cmd}) or not $client->{ready
}) {
230 # redo command with unavailable clients
232 # This will break if the command can cause a redo for
233 # available clients.. this should be fixed sometime
234 $line = ':'.join(',', @unavail).' '.$cmd.$args;
237 # do command with available clients
239 # split up the argument part of the line
240 $args =~ /^((?:(?: [^:])|[^ ])+)?(?: :(.+))?$/;
241 $args = [($1 ? split(' ', $1) : ()), ($2 ? $2 : ())];
242 # find the client and figure out if we need to wait
243 foreach my $c (@avail) {
244 my $client = $heap->{clients
}->{$c};
245 die "Client $c used twice as source (line $heap->{lineno})" if $used->{c
} and not $zero_time->{$cmd};
246 $kernel->call($session, 'cmd_'.$cmd, $client, $args);
247 $used->{$c} = 1 unless $zero_time->{$cmd};
251 die "Unrecognized input line $heap->{lineno}: $line";
255 delete $heap->{redo};
256 $heap->{line
} = $line;
260 # issue new heartbeat with appropriate delay
261 $kernel->delay_set('heartbeat', $delay);
264 sub drv_timeout_expect
{
265 my ($kernel, $session, $client) = @_[KERNEL
, SESSION
, ARG0
];
266 print "ERROR: Dropping timed-out expectation by $client->{name}: ".join(',', @{$client->{expect
}->[0]})."\n";
267 $client->{expect_alarms
}->[0] = undef;
268 unexpect
($kernel, $session, $client);
272 my ($kernel, $session, $client) = @_[KERNEL
, SESSION
, ARG0
];
273 $kernel->call($client->{irc
}, 'connect', $client->{params
});
277 my ($kernel, $heap, $sender, $session, $state, $args) = @_[KERNEL
, HEAP
, SENDER
, SESSION
, ARG0
, ARG1
];
278 if ($state =~ /^irc_(\d\d\d)$/) {
279 my $client = $heap->{sessions
}->{$sender};
280 if (@{$client->{expect
}}
281 and $args->[0] eq $client->{expect
}->[0]->[0]
282 and $client->{expect
}->[0]->[1] eq "$1") {
283 my $expect = $client->{expect
}->[0];
285 for (my $x=2; ($x<=$#$expect) and ($x<=$#$args) and not $mismatch; $x++) {
286 $mismatch = 1 unless $args->[$x] =~ /$expect->[$x]/i;
288 unexpect
($kernel, $session, $client) unless $mismatch;
292 print "ERROR: Unexpected event $state to test driver (from ".$sender->ID.")\n";
296 # client-based command issuers
299 my ($kernel, $heap, $event, $client, $args) = @_[KERNEL
, HEAP
, STATE
, ARG0
, ARG1
];
300 die "Missing arguments" unless $#$args >= 1;
301 # translate each target as appropriate (e.g. *sessionname)
302 my @targets = split(/,/, $args->[0]);
303 foreach my $target (@targets) {
304 if ($target =~ /^\*(.+)$/) {
305 my $other = $heap->{clients
}->{$1} or die "Unknown session name $1 (line $heap->{lineno})\n";
306 $target = $other->{nick
};
309 $kernel->call($client->{irc
}, substr($event, 4), \
@targets, $args->[1]);
313 my ($kernel, $heap, $event, $client, $args) = @_[KERNEL
, HEAP
, STATE
, ARG0
, ARG1
];
315 $kernel->call($client->{irc
}, $event, @$args);
319 my ($kernel, $heap, $client, $args) = @_[KERNEL
, HEAP
, ARG0
, ARG1
];
320 die "Missing argument" unless $#$args >= 0;
321 $kernel->call($client->{irc
}, 'sl', $args->[0]);
325 my ($kernel, $session, $heap, $client, $args) = @_[KERNEL
, SESSION
, HEAP
, ARG0
, ARG1
];
326 die "Missing argument" unless $#$args >= 0;
327 $kernel->call($session, 'disable_client', $client);
328 $kernel->delay_set('enable_client', $args->[0], $client);
332 my ($kernel, $session, $heap, $client, $args) = @_[KERNEL
, SESSION
, HEAP
, ARG0
, ARG1
];
333 die "Missing argument" unless $#$args >= 0;
334 # if argument was comma-delimited, split it up (space-delimited is split by generic parser)
335 $args = [split(/,/, $args->[0])] if $args->[0] =~ /,/;
336 # make sure we only wait if all the other clients are ready
337 foreach my $other (@$args) {
338 if (not $heap->{clients
}->{$other}->{ready
}) {
343 # disable this client, make the others send SYNC to it
344 $kernel->call($session, 'disable_client', $client);
345 $client->{sync_wait
} = [map { $heap->{clients
}->{$_}->{nick
} } @$args];
346 foreach my $other (@$args) {
347 die "Cannot wait on self" if $other eq $client->{name
};
348 $kernel->call($heap->{clients
}->{$other}->{irc
}, 'notice', $client->{nick
}, 'SYNC');
353 my ($kernel, $session, $heap, $client, $args) = @_[KERNEL
, SESSION
, HEAP
, ARG0
, ARG1
];
354 die "Missing argument" unless $#$args >= 0;
355 push @{$client->{expect
}}, $args;
356 push @{$client->{expect_alarms
}}, $kernel->delay_set('timeout_expect', EXPECT_TIMEOUT
, $client);
357 $kernel->call($session, 'disable_client', $client);
360 # handlers for messages from IRC
363 my ($kernel, $session, $client) = @_;
364 shift @{$client->{expect
}};
365 my $alarm_id = shift @{$client->{expect_alarms
}};
366 $kernel->alarm_remove($alarm_id) if $alarm_id;
367 $kernel->call($session, 'enable_client', $client) unless @{$client->{expect
}};
371 my ($kernel, $session, $heap, $poe_sender, $sender, $text) = @_[KERNEL
, SESSION
, HEAP
, SENDER
, ARG0
, ARG1
];
372 my $client = $heap->{sessions
}->{$poe_sender};
373 my $expected = $client->{expect
}->[0];
376 if ($expected->[0] =~ /\*(.+)/) {
377 # we expect *sessionname, so look up session's current nick
380 return 0 if lc($heap->{clients
}->{$exp}->{nick
}) ne lc($1);
381 } elsif ($expected->[0] =~ /^:?(.+!.+)/) {
382 # expect :nick!user@host, so compare whole thing
383 return 0 if lc($1) ne lc($sender);
385 # we only expect :nick, so compare that part
386 $sender =~ /^:?(.+)!/;
387 return 0 if lc($expected->[0]) ne lc($1);
391 return 0 if lc($text) !~ /$expected->[2]/i;
393 # drop expectation of event
394 unexpect
($kernel, $session, $client);
398 my ($kernel, $session, $heap, $sender) = @_[KERNEL
, SESSION
, HEAP
, SENDER
];
399 my $client = $heap->{sessions
}->{$sender};
400 print "Client $client->{name} connected to server $_[ARG0]\n" if $heap->{verbose
};
401 $kernel->call($session, 'enable_client', $client);
404 sub irc_disconnected
{
405 my ($kernel, $session, $heap, $sender, $server) = @_[KERNEL
, SESSION
, HEAP
, SENDER
, ARG0
];
406 my $client = $heap->{sessions
}->{$sender};
407 print "Client $client->{name} disconnected from server $_[ARG0]\n" if $heap->{verbose
};
408 if ($client->{quitting
}) {
409 $kernel->call($sender, 'unregister', 'all');
410 delete $heap->{sessions
}->{$sender};
411 delete $heap->{clients
}->{$client->{name
}};
413 if ($client->{disconnect_expected
}) {
414 delete $client->{disconnect_expected
};
416 print "Got unexpected disconnect for $client->{name} (nick $client->{nick})\n";
418 $kernel->call($session, 'disable_client', $client);
419 $kernel->delay_set('reconnect', $client->{throttled
} ? THROTTLED_TIMEOUT
: RECONNECT_TIMEOUT
, $client);
420 delete $client->{throttled
};
425 my ($kernel, $session, $heap, $sender, $msg) = @_[KERNEL
, SESSION
, HEAP
, SENDER
, ARG0
];
426 my $client = $heap->{sessions
}->{$sender};
427 print "Client $client->{name} (re-)connect error: $_[ARG0]\n";
428 if ($client->{quitting
}) {
429 $kernel->call($sender, 'unregister', 'all');
430 delete $heap->{sessions
}->{$sender};
431 delete $heap->{clients
}->{$client->{name
}};
433 if ($client->{disconnect_expected
}) {
434 delete $client->{disconnect_expected
};
436 print "Got unexpected disconnect for $client->{name} (nick $client->{nick})\n";
438 $kernel->call($session, 'disable_client', $client);
439 $kernel->delay_set('reconnect', $client->{throttled
} ? THROTTLED_TIMEOUT
: RECONNECT_TIMEOUT
, $client);
440 delete $client->{throttled
};
445 my ($kernel, $session, $heap, $sender, $from, $to, $text) = @_[KERNEL
, SESSION
, HEAP
, SENDER
, ARG0
, ARG1
, ARG2
];
446 my $client = $heap->{sessions
}->{$sender};
447 if ($client->{sync_wait
} and $text eq 'SYNC') {
451 for ($x=0; $x<=$#{$client->{sync_wait
}}; $x++) {
452 last if $from eq $client->{sync_wait
}->[$x];
454 # exit if we don't expect them
455 if ($x>$#{$client->{sync_wait
}}) {
456 print "Got unexpected SYNC from $from to $client->{name} ($client->{nick})\n";
459 # remove from the list of people we're waiting for
460 splice @{$client->{sync_wait
}}, $x, 1;
461 # re-enable client if we're done waiting
462 if ($#{$client->{sync_wait
}} == -1) {
463 delete $client->{sync_wait
};
464 $kernel->call($session, 'enable_client', $client);
466 } elsif (@{$client->{expect
}}
467 and $client->{expect
}->[0]->[1] =~ /notice/i) {
468 check_expect
(@_[0..ARG0
], $text);
473 my ($kernel, $session, $heap, $sender, $from, $to, $text) = @_[KERNEL
, SESSION
, HEAP
, SENDER
, ARG0
, ARG1
, ARG2
];
474 my $client = $heap->{sessions
}->{$sender};
475 if (@{$client->{expect
}}
476 and $client->{expect
}->[0]->[1] =~ /msg/i) {
477 check_expect
(@_[0..ARG0
], $text);
482 my ($kernel, $session, $heap, $sender, $from, $to, $text) = @_[KERNEL
, SESSION
, HEAP
, SENDER
, ARG0
, ARG1
, ARG2
];
483 my $client = $heap->{sessions
}->{$sender};
484 if (@{$client->{expect
}}
485 and $client->{expect
}->[0]->[1] =~ /public/i
486 and grep($client->{expect
}->[0]->[2], @$to)) {
487 splice @{$client->{expect
}->[0]}, 2, 1;
488 check_expect
(@_[0..ARG0
], $text);
493 my ($kernel, $session, $heap, $sender, $what) = @_[KERNEL
, SESSION
, HEAP
, SENDER
, ARG0
];
494 my $client = $heap->{sessions
}->{$sender};
495 if (@{$client->{expect
}}
496 and $client->{expect
}->[0]->[1] =~ /error/i) {
497 splice @{$client->{expect
}->[0]}, 2, 1;
498 unexpect
($kernel, $session, $client);
499 $client->{disconnect_expected
} = 1;
501 print "ERROR: From server to $client->{name}: $what\n";
503 $client->{throttled
} = 1 if $what =~ /throttled/i;