From 880bb74a2cc77e58aa99cbaeb300435316417e76 Mon Sep 17 00:00:00 2001 From: Mike Taylor Date: Fri, 6 Oct 2006 11:33:07 +0000 Subject: [PATCH] Many radical changes to the IRSpy engine, enabling a far more asynchronous approach. Work remains to be done on the engine, but there's enough here that test can now be written. --- lib/ZOOM/IRSpy.pm | 276 +++++++++++++++++++++++++++-------- lib/ZOOM/IRSpy/Connection.pm | 157 ++++++++++++++++++++ lib/ZOOM/IRSpy/Node.pm | 63 ++++++++ lib/ZOOM/IRSpy/Task.pm | 87 +++++++++++ lib/ZOOM/IRSpy/Task/Connect.pm | 41 ++++++ lib/ZOOM/IRSpy/Task/Search.pm | 73 +++++++++ lib/ZOOM/IRSpy/Test.pm | 42 ++---- lib/ZOOM/IRSpy/Test/Main.pm | 14 +- lib/ZOOM/IRSpy/Test/Ping.pm | 30 ++-- lib/ZOOM/IRSpy/Test/Search/Bib1.pm | 74 +++------- lib/ZOOM/IRSpy/Test/Search/Main.pm | 45 +----- lib/ZOOM/IRSpy/Test/Search/Title.pm | 47 +++--- lib/ZOOM/Pod.pm | 17 ++- 13 files changed, 745 insertions(+), 221 deletions(-) create mode 100644 lib/ZOOM/IRSpy/Connection.pm create mode 100644 lib/ZOOM/IRSpy/Node.pm create mode 100644 lib/ZOOM/IRSpy/Task.pm create mode 100644 lib/ZOOM/IRSpy/Task/Connect.pm create mode 100644 lib/ZOOM/IRSpy/Task/Search.pm diff --git a/lib/ZOOM/IRSpy.pm b/lib/ZOOM/IRSpy.pm index a8f5d90..103889b 100644 --- a/lib/ZOOM/IRSpy.pm +++ b/lib/ZOOM/IRSpy.pm @@ -1,16 +1,29 @@ -# $Id: IRSpy.pm,v 1.21 2006-09-27 12:49:46 mike Exp $ +# $Id: IRSpy.pm,v 1.22 2006-10-06 11:33:07 mike Exp $ package ZOOM::IRSpy; use 5.008; use strict; use warnings; + +use Data::Dumper; # For debugging only +use ZOOM::IRSpy::Node; +use ZOOM::IRSpy::Connection; use ZOOM::IRSpy::Record; -use ZOOM::Pod; our @ISA = qw(); our $VERSION = '0.02'; + +# Enumeration for callback functions to return +package ZOOM::IRSpy::Status; +sub OK { 29 } # No problems, task is still progressing +sub TASK_DONE { 18 } # Task is complete, next task should begin +sub TEST_GOOD { 8 } # Whole test is complete, and succeeded +sub TEST_BAD { 31 } # Whole test is complete, and failed +package ZOOM::IRSpy; + + =head1 NAME ZOOM::IRSpy - Perl extension for discovering and analysing IR services @@ -33,6 +46,8 @@ BEGIN { ZOOM::Log::mask_str("irspy"); ZOOM::Log::mask_str("irspy_test"); ZOOM::Log::mask_str("irspy_debug"); + ZOOM::Log::mask_str("irspy_event"); + ZOOM::Log::mask_str("irspy_unhandled"); } sub new { @@ -51,8 +66,7 @@ sub new { allrecords => 1, # unless overridden by targets() query => undef, # filled in later targets => undef, # filled in later - target2record => undef, # filled in later - pod => undef, # filled in later + connections => undef, # filled in later tests => [], # stack of tests currently being executed }, $class; $this->log("irspy", "starting up with database '$dbname'"); @@ -86,8 +100,7 @@ sub targets { $this->log("irspy_debug", "rewriting '$target' to '$newtarget'"); $target = $newtarget; # This is written through the ref } - push @qlist, - (qq[(host = "$host" and port = "$port" and path="$db")]); + push @qlist, (qq[(host="$host" and port="$port" and path="$db")]); } $this->{targets} = \@targets; @@ -151,8 +164,10 @@ sub initialise { } } + $this->log("irspy_debug", "query '", $this->{query}, "'"); my $rs = $this->{conn}->search(new ZOOM::Query::CQL($this->{query})); - #print "size='", $rs->size(), "'\n"; + delete $this->{query}; # No longer needed at all + $this->log("irspy_debug", "found ", $rs->size(), " target records"); foreach my $i (1 .. $rs->size()) { my $target = _render_record($rs, $i-1, "id"); my $zeerex = _render_record($rs, $i-1, "zeerex"); @@ -163,21 +178,31 @@ sub initialise { if $this->{allrecords}; } + # Make records for targets not previously in the database foreach my $target (keys %target2record) { my $record = $target2record{$target}; if (!defined $record) { $this->log("irspy_debug", "made new record for '$target'"); - #print STDERR "making '$target' record without zeerex\n"; $target2record{$target} = new ZOOM::IRSpy::Record($this, $target); } else { $this->log("irspy_debug", "using existing record for '$target'"); } } - $this->{target2record} = \%target2record; - $this->{pod} = new ZOOM::Pod(@{ $this->{targets} }); - delete $this->{targets}; # The information is now in the Pod. - delete $this->{query}; # Not needed at all + my @connections; + foreach my $target (@{ $this->{targets} }) { + my $conn = new ZOOM::IRSpy::Connection($this, $target, 0, async => 1); + my $record = delete $target2record{lc($target)}; + $conn->record($record); + push @connections, $conn; + } + die("remaining target2record = { " . + join(", ", map { "$_ ->'" . $target2record{$_}. "'" } + sort keys %target2record) . " }") + if %target2record; + + $this->{connections} = \@connections; + delete $this->{targets}; # The information is now in {connections} } @@ -195,19 +220,12 @@ sub _render_record { } -# Returns: -# 0 all tests successfully run -# 1 some tests skipped -# -sub check { +sub _rewrite_records { my $this = shift(); - my($test) = @_; - $test = "Main" if !defined $test; - my $res = $this->_run_test($test); - foreach my $target (sort keys %{ $this->{target2record} }) { - my $rec = $this->{target2record}->{$target}; - # Write record back to database + # Write modified records back to database + foreach my $conn (@{ $this->{connections} }) { + my $rec = $conn->record(); my $p = $this->{conn}->package(); $p->option(action => "specialUpdate"); my $xml = $rec->{zeerex}->toString(); @@ -225,18 +243,165 @@ sub check { print "Updated with xml=
\n
$xml
\n"; } } - - return $res; } -sub _run_test { +# New approach: +# 1. Gather declarative information about test hierarchy. +# 2. For each connection, start the initial test -- invokes run(). +# 3. Run each connection's first queued task. +# 4. while (1) { wait() }. Callbacks return a ZOOM::IRSpy::Status value +# No individual test ever calls wait: tests just set up tasks. +# +sub check { my $this = shift(); my($tname) = @_; + $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) = @_; + die("$0: test-hierarchy loop detected: " . - join(" -> ", @{ $this->{tests} }, $tname)) - if grep { $_ eq $tname } @{ $this->{tests} }; + join(" -> ", @ancestors, $tname)) + if grep { $_ eq $tname } @ancestors; eval { my $slashSeperatedTname = $tname; @@ -245,47 +410,43 @@ sub _run_test { }; if ($@) { $this->log("warn", "can't load test '$tname': skipping", $@ =~ /^Can.t locate/ ? () : " ($@)"); - return 1; + return undef; + } + + $this->log("irspy", "adding test '$tname'"); + my @subtests; + foreach my $subtname ("ZOOM::IRSpy::Test::$tname"->subtests($this)) { + my $subtest = $this->_gather_tests($subtname, @ancestors, $tname); + push @subtests, $subtest if defined $subtest; } - $this->log("irspy", "running test '$tname'"); - push @{ $this->{tests} }, $tname; - my $test = "ZOOM::IRSpy::Test::$tname"->new($this); - my $res = $test->run(); - $this->pod()->remove_callbacks(); - pop @{ $this->{tests} }; - return $res; + return new ZOOM::IRSpy::Node($tname, @subtests); } -# Access methods for the use of Test modules -sub pod { +sub _next_test { my $this = shift(); - return $this->{pod}; -} + my($address, $omit_child) = @_; -sub record { - my $this = shift(); - my($target) = @_; + $this->log("irspy", "checking for next test after '$address'"); - if (ref($target) && $target->isa("ZOOM::Connection")) { - # Can be called with a Connection instead of a target-name - my $conn = $target; - $target = $conn->option("host"); + # Try first child + if (!$omit_child) { + my $maybe = $address eq "" ? "0" : "$address:0"; + return $maybe if $this->{tree}->select($maybe); } - return $this->{target2record}->{lc($target)}; -} + # The top-level node has no successor or parent + return undef if $address eq ""; + # Try next sibling child + my @components = split /:/, $address; + my $last = pop @components; + my $maybe = join(":", @components, $last+1); + return $maybe if $this->{tree}->select($maybe); -# Utility method, really nothing to do with IRSpy -sub isodate { - my $this = shift(); - my($time) = @_; - - my($sec, $min, $hour, $mday, $mon, $year) = localtime($time); - return sprintf("%04d-%02d-%02dT%02d:%02d:%02d", - $year+1900, $mon+1, $mday, $hour, $min, $sec); + # This node is exhausted: try the parent's successor + return $this->_next_test(join(":", @components), 1) } @@ -316,4 +477,5 @@ at your option, any later version of Perl 5 you may have available. =cut + 1; diff --git a/lib/ZOOM/IRSpy/Connection.pm b/lib/ZOOM/IRSpy/Connection.pm new file mode 100644 index 0000000..74c24a8 --- /dev/null +++ b/lib/ZOOM/IRSpy/Connection.pm @@ -0,0 +1,157 @@ +# $Id: Connection.pm,v 1.1 2006-10-06 11:33:07 mike Exp $ + +package ZOOM::IRSpy::Connection; + +use 5.008; +use strict; +use warnings; + +use ZOOM; +our @ISA = qw(ZOOM::Connection); + +use ZOOM::IRSpy::Task::Connect; +use ZOOM::IRSpy::Task::Search; + + +=head1 NAME + +ZOOM::IRSpy::Connection - ZOOM::Connection subclass with IRSpy functionality + +=head1 DESCRIPTION + +This class provides some additional private data and methods that are +used by IRSpy but which would be useless in any other application. +Keeping the private data in these objects removes the need for ugly +mappings in the IRSpy object itself; adding the methods makes the +application code cleaner. + +The constructor takes an additional first argument, a reference to the +IRSpy object that it is associated with. + +=cut + +sub new { + my $class = shift(); + my $irspy = shift(); + + my $this = $class->SUPER::new(@_); + $this->{irspy} = $irspy; + $this->{record} = undef; + $this->{tasks} = undef; + + return $this; +} + + +sub irspy { + my $this = shift(); + return $this->{irspy}; +} + + +sub record { + my $this = shift(); + my($new) = @_; + + my $old = $this->{record}; + $this->{record} = $new if defined $new; + return $old; +} + + +sub tasks { + my $this = shift(); + my($new) = @_; + + my $old = $this->{tasks}; + $this->{tasks} = $new if defined $new; + return $old; +} + + +sub current_task { + my $this = shift(); + my($new) = @_; + + my $old = $this->{current_task}; + if (defined $new) { + $this->{current_task} = $new; + $this->log("irspy_debug", "set current task to $new"); + } + + return $old; +} + + +sub log { + my $this = shift(); + my($level, @msg) = @_; + + $this->irspy()->log($level, $this->option("host"), " ", @msg); +} + + +sub irspy_connect { + my $this = shift(); + my(%cb) = @_; + + $this->add_task(new ZOOM::IRSpy::Task::Connect($this, %cb)); + $this->log("irspy", "registered connect()"); +} + + +sub irspy_search_pqf { + my $this = shift(); + my($query, %cb) = @_; + + $this->add_task(new ZOOM::IRSpy::Task::Search($query, $this, %cb)); + $this->log("irspy", "registered search_pqf($query)"); +} + + +sub add_task { + my $this = shift(); + my($task) = @_; + + my $tasks = $this->tasks(); + if (!defined $tasks) { + $this->tasks([ $task ]); + } else { + $tasks->[-1]->{next} = $task; + push @$tasks, $task; + } + + $this->log("irspy", "added task $task"); +} + + +sub start_task { + my $this = shift(); + my($task) = @_; + die "no task defined for " . $this->option("host") + if !defined $task; + + $this->current_task($task); + $task->run(); +} + + +=head1 SEE ALSO + +ZOOM::IRSpy + +=head1 AUTHOR + +Mike Taylor, Emike@indexdata.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2006 by Index Data ApS. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8.7 or, +at your option, any later version of Perl 5 you may have available. + +=cut + +1; diff --git a/lib/ZOOM/IRSpy/Node.pm b/lib/ZOOM/IRSpy/Node.pm new file mode 100644 index 0000000..20559a2 --- /dev/null +++ b/lib/ZOOM/IRSpy/Node.pm @@ -0,0 +1,63 @@ +# $Id: Node.pm,v 1.1 2006-10-06 11:33:07 mike Exp $ + +package ZOOM::IRSpy::Node; + +use 5.008; +use strict; +use warnings; + + +sub new { + my $class = shift(); + my($name, @subtests) = @_; + return bless { + name => $name, + subtests => \@subtests, + }, $class; +} + +sub name { + my $this = shift(); + return $this->{name}; +} + +sub subtests { + my $this = shift(); + return @{ $this->{subtests} }; +} + +sub print { + my $this = shift(); + my($level) = @_; + + print "\t" x $level, $this->name(); + if (my @sub = $this->subtests()) { + print " = {\n"; + foreach my $sub (@sub) { + $sub->print($level+1); + } + print "\t" x $level, "}"; + } + print "\n"; +} + +# Addresses are of the form: +# (empty) - the root +# 2 - subtree #2 (i.e. the third subtree) of the root +# 2:1 - subtree #1 of subtree #2, etc +sub select { + my $this = shift(); + my($address) = @_; + + my @sub = $this->subtests(); + if ($address eq "") { + return $this; + } elsif (my($head, $tail) = $address =~ /(.*):(.*)/) { + return $sub[$head]->select($tail); + } else { + return $sub[$address]; + } +} + + +1; diff --git a/lib/ZOOM/IRSpy/Task.pm b/lib/ZOOM/IRSpy/Task.pm new file mode 100644 index 0000000..04d5a3c --- /dev/null +++ b/lib/ZOOM/IRSpy/Task.pm @@ -0,0 +1,87 @@ +# $Id: Task.pm,v 1.1 2006-10-06 11:33:07 mike Exp $ + +package ZOOM::IRSpy::Task; + +use 5.008; +use strict; +use warnings; + +=head1 NAME + +ZOOM::IRSpy::Task - base class for tasks in IRSpy + +=head1 SYNOPSIS + + use ZOOM::IRSpy::Task; + package ZOOM::IRSpy::Task::SomeTask; + our @ISA = qw(ZOOM::IRSpy::Task); + # ... override methods + +=head1 DESCRIPTION + +This class provides a base-class from which individual IRSpy task +classes can be derived. For example, C +will represent a searching task, carrying with it a query, a pointer +to a result-set, etc. + +The base class provides nothing more exciting than a link to a +callback function to be called when the task is complete, and a +pointer to the next task to be performed after this. + +=cut + +sub new { + my $class = shift(); + my($conn, %cb) = @_; + + return bless { + irspy => $conn->{irspy}, + conn => $conn, + cb => \%cb, + timeRegistered => time(), + }, $class; +} + + +sub irspy { + my $this = shift(); + return $this->{irspy}; +} + +sub conn { + my $this = shift(); + return $this->{conn}; +} + +sub run { + my $this = shift(); + die "can't run base-class task $this"; +} + +sub render { + my $this = shift(); + return "[base-class] " . ref($this); +} + +use overload '""' => \&render; + + +=head1 SEE ALSO + +ZOOM::IRSpy + +=head1 AUTHOR + +Mike Taylor, Emike@indexdata.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2006 by Index Data ApS. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8.7 or, +at your option, any later version of Perl 5 you may have available. + +=cut + +1; diff --git a/lib/ZOOM/IRSpy/Task/Connect.pm b/lib/ZOOM/IRSpy/Task/Connect.pm new file mode 100644 index 0000000..1bfb8c4 --- /dev/null +++ b/lib/ZOOM/IRSpy/Task/Connect.pm @@ -0,0 +1,41 @@ +# $Id: Connect.pm,v 1.1 2006-10-06 11:33:08 mike Exp $ + +# See ZOOM/IRSpy/Task/Search.pm for documentation + +package ZOOM::IRSpy::Task::Connect; + +use 5.008; +use strict; +use warnings; + +use ZOOM::IRSpy::Task; +our @ISA = qw(ZOOM::IRSpy::Task); + +sub new { + my $class = shift(); + + return $class->SUPER::new(@_); +} + +sub run { + my $this = shift(); + + my $conn = $this->conn(); + $this->irspy()->log("irspy_test", $conn->option("host"), + " connecting"); + # Actually, connections have already been connected. Redoing this + # won't hurt -- in fact, it's a no-op. But because it's a no-op, + # it doesn't cause any events, which means that the very next call + # of ZOOM::event() will return 0, and IRSpy will fall through the + # event loop. Not good. Not sure how to fix this. + $conn->connect($conn->option("host")); +} + +sub render { + my $this = shift(); + return ref($this) . " " . $this->conn()->option("host"); +} + +use overload '""' => \&render; + +1; diff --git a/lib/ZOOM/IRSpy/Task/Search.pm b/lib/ZOOM/IRSpy/Task/Search.pm new file mode 100644 index 0000000..8b09d86 --- /dev/null +++ b/lib/ZOOM/IRSpy/Task/Search.pm @@ -0,0 +1,73 @@ +# $Id: Search.pm,v 1.1 2006-10-06 11:33:08 mike Exp $ + +package ZOOM::IRSpy::Task::Search; + +use 5.008; +use strict; +use warnings; + +use ZOOM::IRSpy::Task; +our @ISA = qw(ZOOM::IRSpy::Task); + +=head1 NAME + +ZOOM::IRSpy::Task::Search - a searching task for IRSpy + +=head1 SYNOPSIS + + ## to follow + +=head1 DESCRIPTION + + ## to follow + +=cut + +sub new { + my $class = shift(); + my($query) = shift(); + + my $this = $class->SUPER::new(@_); + $this->{query} = $query; + $this->{rs} = undef; + return $this; +} + +sub run { + my $this = shift(); + + my $conn = $this->conn(); + my $query = $this->{query}; + $this->irspy()->log("irspy_test", $conn->option("host"), + " searching for '$query'"); + $this->{rs} = $conn->search_pqf($query); + # Wow -- that's it. +} + +sub render { + my $this = shift(); + return ref($this) . " " . $this->{query}; +} + +use overload '""' => \&render; + + +=head1 SEE ALSO + +ZOOM::IRSpy + +=head1 AUTHOR + +Mike Taylor, Emike@indexdata.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2006 by Index Data ApS. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8.7 or, +at your option, any later version of Perl 5 you may have available. + +=cut + +1; diff --git a/lib/ZOOM/IRSpy/Test.pm b/lib/ZOOM/IRSpy/Test.pm index 20fa772..83ad686 100644 --- a/lib/ZOOM/IRSpy/Test.pm +++ b/lib/ZOOM/IRSpy/Test.pm @@ -1,4 +1,4 @@ -# $Id: Test.pm,v 1.3 2006-07-21 11:49:27 mike Exp $ +# $Id: Test.pm,v 1.4 2006-10-06 11:33:07 mike Exp $ package ZOOM::IRSpy::Test; @@ -6,6 +6,9 @@ use 5.008; use strict; use warnings; +use Exporter 'import'; +our @EXPORT = qw(isodate); + =head1 NAME ZOOM::IRSpy::Test - base class for tests in IRSpy @@ -20,38 +23,23 @@ I<## To follow> =cut -sub new { - my $class = shift(); - my($irspy) = @_; - - return bless { - irspy => $irspy, - }, $class; -} - - -sub irspy { - my $this = shift(); - return $this->{irspy}; -} +sub subtests { () } +sub start { + my $class = shift(); + my($conn) = @_; -sub run { - my $this = shift(); - die "can't run the base-class test"; + die "can't start the base-class test"; } -sub run_tests { - my $this = shift(); - my @tname = @_; - my $res = 0; - foreach my $tname (@tname) { - my $sub = $this->irspy()->_run_test($tname); - $res = $sub if $sub > $res; - } +# Utility function, really nothing to do with IRSpy +sub isodate { + my($time) = @_; - return $res; + my($sec, $min, $hour, $mday, $mon, $year) = localtime($time); + return sprintf("%04d-%02d-%02dT%02d:%02d:%02d", + $year+1900, $mon+1, $mday, $hour, $min, $sec); } diff --git a/lib/ZOOM/IRSpy/Test/Main.pm b/lib/ZOOM/IRSpy/Test/Main.pm index b4e9d73..e9ce6aa 100644 --- a/lib/ZOOM/IRSpy/Test/Main.pm +++ b/lib/ZOOM/IRSpy/Test/Main.pm @@ -1,4 +1,4 @@ -# $Id: Main.pm,v 1.6 2006-10-02 13:08:42 sondberg Exp $ +# $Id: Main.pm,v 1.7 2006-10-06 11:33:08 mike Exp $ package ZOOM::IRSpy::Test::Main; @@ -7,8 +7,7 @@ use strict; use warnings; use ZOOM::IRSpy::Test; -our @ISA; -@ISA = qw(ZOOM::IRSpy::Test); +our @ISA = qw(ZOOM::IRSpy::Test); =head1 NAME @@ -25,10 +24,13 @@ I<## To follow> =cut -sub run { - my $this = shift(); +sub subtests { qw(Search::Title Search::Bib1) } - return $this->run_tests(qw(Ping Search::Main)); +sub start { + my $class = shift(); + my($conn) = @_; + + # Do nothing -- this test is just a subtest container } diff --git a/lib/ZOOM/IRSpy/Test/Ping.pm b/lib/ZOOM/IRSpy/Test/Ping.pm index f81aaaf..1cda0cd 100644 --- a/lib/ZOOM/IRSpy/Test/Ping.pm +++ b/lib/ZOOM/IRSpy/Test/Ping.pm @@ -1,4 +1,4 @@ -# $Id: Ping.pm,v 1.11 2006-09-13 16:29:55 mike Exp $ +# $Id: Ping.pm,v 1.12 2006-10-06 11:33:08 mike Exp $ # See the "Main" test package for documentation @@ -9,20 +9,15 @@ use strict; use warnings; use ZOOM::IRSpy::Test; -our @ISA; -@ISA = qw(ZOOM::IRSpy::Test); +our @ISA = qw(ZOOM::IRSpy::Test); -sub run { - my $this = shift(); - my $irspy = $this->irspy(); - my $pod = $irspy->pod(); +sub start { + my $class = shift(); + my($conn) = @_; - $pod->callback(ZOOM::Event::CONNECT, \&connected); - $pod->callback("exception", \¬_connected); - my $err = $pod->wait($irspy); - - return 0; + $conn->irspy_connect(ZOOM::Event::CONNECT, \&connected, + "exception", \¬_connected); } @@ -30,15 +25,14 @@ sub connected { maybe_connected(@_, 1) } sub not_connected { maybe_connected(@_, 0) } sub maybe_connected { - my($conn, $irspy, $rs, $event, $ok) = @_; + my($conn, $rs, $event, $ok) = @_; - $irspy->log("irspy_test", $conn->option("host"), - ($ok ? "" : " not"), " connected"); - my $rec = $irspy->record($conn); + $conn->log("irspy_test", ($ok ? "" : "not "), "connected"); + my $rec = $conn->record(); $rec->append_entry("irspy:status", "" . - $irspy->isodate(time()) . ""); + isodate(time()) . ""); $conn->option(pod_omit => 1) if !$ok; - return 0; + return ZOOM::IRSpy::Status::TASK_DONE; } diff --git a/lib/ZOOM/IRSpy/Test/Search/Bib1.pm b/lib/ZOOM/IRSpy/Test/Search/Bib1.pm index 1b1cfbc..93bcd7a 100644 --- a/lib/ZOOM/IRSpy/Test/Search/Bib1.pm +++ b/lib/ZOOM/IRSpy/Test/Search/Bib1.pm @@ -1,4 +1,4 @@ -# $Id: Bib1.pm,v 1.4 2006-10-02 13:02:10 sondberg Exp $ +# $Id: Bib1.pm,v 1.5 2006-10-06 11:33:08 mike Exp $ # See the "Main" test package for documentation @@ -7,70 +7,40 @@ package ZOOM::IRSpy::Test::Search::Bib1; use 5.008; use strict; use warnings; -use Data::Dumper; use ZOOM::IRSpy::Test; our @ISA = qw(ZOOM::IRSpy::Test); -our @Bib1_Attr = qw(1 2 3 4 5 6 7 8 9); -sub run { - my $this = shift(); - my $irspy = $this->irspy(); - my $pod = $irspy->pod(); - - $pod->callback(ZOOM::Event::RECV_SEARCH, \&found); - $pod->callback("exception", \&error_handler); - $pod->callback(ZOOM::Event::ZEND, \&continue); - - foreach my $attr (@Bib1_Attr) { - $pod->search_pqf('@attr 1=' . $attr . ' water' ); - $irspy->{'handle'}->{'attr'} = $attr; - my $err = $pod->wait($irspy); +sub start { + my $class = shift(); + my($conn) = @_; + + my @attrs = (1, # personal name + 4, # title + 52, # subject + 1003, # author + 1016, # any + ); + foreach my $attr (@attrs) { + $conn->irspy_search_pqf("\@attr 1=$attr mineral", + ZOOM::Event::RECV_SEARCH, \&found, + exception => \&error); } - - return 0; } sub found { - my($conn, $irspy, $rs, $event) = @_; - my $href = $irspy->{'handle'}; - my $attr = $href->{'attr'}; - my $n = $rs->size(); - my $rec = $irspy->record($conn); - - $irspy->log("irspy_test", $conn->option("host"), - " Bib-1 attribute=$attr search found $n record", - $n==1 ? "" : "s"); - - $rec->append_entry("irspy:status", "" . $irspy->isodate(time()) . - ""); - return 0; -} + my($conn, $task, $event) = @_; + my $n = $task->{rs}->size(); + $conn->log("irspy_test", "search found $n record", $n==1 ? "" : "s"); + my $rec = $conn->record(); + $rec->append_entry("irspy:status", "" . + isodate(time()) . ""); -sub continue { - my ($conn, $irspy, $rs, $event) = @_; - - print "ZEND\n"; + return ZOOM::IRSpy::Status::TASK_DONE; } - -sub error_handler { maybe_connected(@_, 0) } - -sub maybe_connected { - my($conn, $irspy, $rs, $event, $ok) = @_; - - $irspy->log("irspy_test", $conn->option("host"), - ($ok ? "" : " not"), " connected"); - my $rec = $irspy->record($conn); - $rec->append_entry("irspy:status", "" . - $irspy->isodate(time()) . ""); - $conn->option(pod_omit => 1) if !$ok; - return 0; -} - 1; diff --git a/lib/ZOOM/IRSpy/Test/Search/Main.pm b/lib/ZOOM/IRSpy/Test/Search/Main.pm index 9cf3470..c9166db 100644 --- a/lib/ZOOM/IRSpy/Test/Search/Main.pm +++ b/lib/ZOOM/IRSpy/Test/Search/Main.pm @@ -1,4 +1,4 @@ -# $Id: Main.pm,v 1.1 2006-10-02 13:08:42 sondberg Exp $ +# $Id: Main.pm,v 1.2 2006-10-06 11:33:08 mike Exp $ package ZOOM::IRSpy::Test::Search::Main; @@ -7,47 +7,12 @@ use strict; use warnings; use ZOOM::IRSpy::Test; -our @ISA; -@ISA = qw(ZOOM::IRSpy::Test); +our @ISA = qw(ZOOM::IRSpy::Test); +sub subtests { qw(Search::Title Search::Bib1) } -=head1 NAME - -ZOOM::IRSpy::Test::Main::Search::Main - a single test for IRSpy - -=head1 SYNOPSIS - - ## To follow - -=head1 DESCRIPTION - -I<## To follow> - -=cut - -sub run { - my $this = shift(); - - return $this->run_tests(qw(Search::Bib1)); +sub start { + # Do nothing -- this test is just a subtest container } - -=head1 SEE ALSO - -ZOOM::IRSpy - -=head1 AUTHOR - -Mike Taylor, Emike@indexdata.comE - -=head1 COPYRIGHT AND LICENSE - -Copyright (C) 2006 by Index Data ApS. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself, either Perl version 5.8.7 or, -at your option, any later version of Perl 5 you may have available. - -=cut - 1; diff --git a/lib/ZOOM/IRSpy/Test/Search/Title.pm b/lib/ZOOM/IRSpy/Test/Search/Title.pm index 2bf4f09..4875598 100644 --- a/lib/ZOOM/IRSpy/Test/Search/Title.pm +++ b/lib/ZOOM/IRSpy/Test/Search/Title.pm @@ -1,4 +1,4 @@ -# $Id: Title.pm,v 1.4 2006-09-13 16:30:27 mike Exp $ +# $Id: Title.pm,v 1.5 2006-10-06 11:33:08 mike Exp $ # See the "Main" test package for documentation @@ -9,34 +9,41 @@ use strict; use warnings; use ZOOM::IRSpy::Test; -our @ISA; -@ISA = qw(ZOOM::IRSpy::Test); +our @ISA = qw(ZOOM::IRSpy::Test); -sub run { - my $this = shift(); - my $irspy = $this->irspy(); - my $pod = $irspy->pod(); +sub start { + my $class = shift(); + my($conn) = @_; - $pod->callback(ZOOM::Event::RECV_SEARCH, \&found); - $pod->search_pqf('@attr 1=4 computer'); - my $err = $pod->wait($irspy); - ### Should notice failure and log it. - - return 0; + $conn->irspy_search_pqf('@attr 1=4 mineral', + ZOOM::Event::RECV_SEARCH, \&found, + "exception", \&error); } sub found { - my($conn, $irspy, $rs, $event) = @_; + my($conn, $task, $event) = @_; - my $n = $rs->size(); - $irspy->log("irspy_test", $conn->option("host"), - " title search found $n record", $n==1 ? "" : "s"); - my $rec = $irspy->record($conn); + my $n = $task->{rs}->size(); + $conn->log("irspy_test", + "title search found $n record", $n==1 ? "" : "s"); + my $rec = $conn->record(); $rec->append_entry("irspy:status", "" . - $irspy->isodate(time()) . ""); - return 0; + isodate(time()) . ""); + + return ZOOM::IRSpy::Status::TASK_DONE; +} + + +sub error { + my($conn, $task, $exception) = @_; + + $conn->log("irspy_test", "error: $exception"); + my $rec = $conn->record(); + $rec->append_entry("irspy:status", "" . + isodate(time()) . ""); + return ZOOM::IRSpy::Status::TEST_BAD; } diff --git a/lib/ZOOM/Pod.pm b/lib/ZOOM/Pod.pm index 3e2f9ce..5faee4d 100644 --- a/lib/ZOOM/Pod.pm +++ b/lib/ZOOM/Pod.pm @@ -1,4 +1,4 @@ -# $Id: Pod.pm,v 1.21 2006-09-27 12:48:20 mike Exp $ +# $Id: Pod.pm,v 1.22 2006-10-06 11:33:07 mike Exp $ package ZOOM::Pod; @@ -111,6 +111,21 @@ sub new { }, $class; } + +=head2 connections() + + @c = $pod->connections(); + +Returns a list of the connection objects in the pod. + +=cut + +sub connections { + my $this = shift(); + return @{ $this->{conn} } +} + + =head2 option() $oldElemSet = $pod->option("elementSetName"); -- 1.7.10.4