+ $tname = "Main" if !defined $tname;
+ $this->{tree} = $this->_gather_tests($tname)
+ or die "No tests defined";
+ #$this->{tree}->print(0);
+
+ my @conn = @{ $this->{connections} };
+ foreach my $conn (@conn) {
+ $this->_start_test($conn, "");
+ }
+
+ while ((my $i0 = ZOOM::event(\@conn)) != 0) {
+ my $conn = $conn[$i0-1];
+ my $target = $conn->option("host");
+ my $ev = $conn->last_event();
+ my $evstr = ZOOM::event_str($ev);
+ $this->log("irspy_event", "$target event $ev ($evstr)");
+
+ my $task = $conn->current_task();
+ my $res;
+ eval {
+ $conn->_check();
+ }; if ($@) {
+ # This is a nasty hack. An error in, say, a search response,
+ # becomes visible to ZOOM before the Receive Data event is
+ # sent and persists until after the End, which means that
+ # successive events each report the same error. So we
+ # just ignore errors on "unimportant" events. Let's hope
+ # this doesn't come back and bite us.
+ if ($ev == ZOOM::Event::RECV_DATA ||
+ $ev == ZOOM::Event::RECV_APDU ||
+ $ev == ZOOM::Event::ZEND) {
+ $this->log("irspy_event", "$target ignoring error ",
+ "on event $ev ($evstr): $@");
+ } else {
+ my $sub = $task->{cb}->{exception};
+ die $@ if !defined $sub;
+ $res = &$sub($conn, $task, $@);
+ goto HANDLE_RESULT;
+ }
+ }
+
+ my $sub = $task ? $task->{cb}->{$ev} : undef;
+ if (!defined $sub) {
+ $conn->log("irspy_unhandled", "event $ev ($evstr)");
+ # Catch the case of a pure-container test ending
+ if ($ev == ZOOM::Event::ZEND && !$conn->current_task()) {
+ $conn->log("irspy", "last event, no task queued");
+ goto NEXT_TEST;
+ }
+ next;
+ }
+
+ $res = &$sub($conn, $task, $ev);
+ HANDLE_RESULT:
+ if ($res == ZOOM::IRSpy::Status::OK) {
+ # Nothing to do -- life continues
+
+ } elsif ($res == ZOOM::IRSpy::Status::TASK_DONE) {
+ my $task = $conn->current_task();
+ die "can't happen" if !$task;
+ $conn->log("irspy", "completed task $task");
+ my $nexttask = $task->{next};
+ if (defined $nexttask) {
+ $conn->log("irspy_debug", "next task is '$nexttask'");
+ $conn->start_task($nexttask);
+ } else {
+ $conn->log("irspy_debug", "jumping to NEXT_TEST");
+ $conn->current_task(0);
+ goto NEXT_TEST;
+ }
+
+ } elsif ($res == ZOOM::IRSpy::Status::TEST_GOOD) {
+ $conn->log("irspy", "test completed (GOOD)");
+ NEXT_TEST:
+ my $address = $conn->option("address");
+ my $nextaddr = $this->_next_test($address);
+ if (defined $nextaddr) {
+ $this->_start_test($conn, $nextaddr);
+ } else {
+ $conn->log("irspy", "has no tests after '$address'");
+ # Nothing else to do: we will get no more meaningful
+ # events on this connection, and when all the
+ # connections have reached this state, ZOOM::event()
+ # will return 0 and we will fall out of the loop.
+ }
+
+ } elsif ($res == ZOOM::IRSpy::Status::TEST_BAD) {
+ $conn->log("irspy", "test completed (BAD)");
+ ### Should skip over remaining sibling tests
+ goto NEXT_TEST;
+ }
+ }
+
+ $this->log("irspy_event", "ZOOM::event() returned 0");
+
+ #$this->_rewrite_records();
+ return 0; # What does this mean?
+}
+
+
+# Preconditions:
+# - called only when there no tasks remain for the connection
+# - called with valid address
+sub _start_test {
+ my $this = shift();
+ my($conn, $address) = @_;
+ {
+ my $task = $conn->current_task();
+ die "_start_test(): $conn already has task $task"
+ if $task;
+ }
+
+ my $node = $this->{tree}->select($address)
+ or die "_start_test(): invalid address '$address'";
+
+ $conn->option(address => $address);
+ my $tname = $node->name();
+ $this->log("irspy", $conn->option("host"),
+ " starting test '$address' = $tname");
+
+ # We will need to find the first of the tasks that are added by
+ # the test we're about to start, so we can start that task. This
+ # requires a little trickery: noting the current length of the
+ # tasks array first, then fetching the next one off the end.
+ my $alltasks = $conn->tasks();
+ my $ntasks = defined $alltasks ? @$alltasks : 0;
+ my $test = "ZOOM::IRSpy::Test::$tname"->start($conn);
+
+ $alltasks = $conn->tasks();
+ if (defined $alltasks && @$alltasks > $ntasks) {
+ my $task = $alltasks->[$ntasks];
+ $conn->start_task($task);
+ } else {
+ $this->log("irspy", "no tasks added for test '$address' = $tname");
+ }
+}
+
+
+sub _gather_tests {
+ my $this = shift();
+ my($tname, @ancestors) = @_;
+