1 # $Id: IRSpy.pm,v 1.23 2006-10-06 16:52:50 mike Exp $
9 use Data::Dumper; # For debugging only
10 use ZOOM::IRSpy::Node;
11 use ZOOM::IRSpy::Connection;
12 use ZOOM::IRSpy::Record;
15 our $VERSION = '0.02';
18 # Enumeration for callback functions to return
19 package ZOOM::IRSpy::Status;
20 sub OK { 29 } # No problems, task is still progressing
21 sub TASK_DONE { 18 } # Task is complete, next task should begin
22 sub TEST_GOOD { 8 } # Whole test is complete, and succeeded
23 sub TEST_BAD { 31 } # Whole test is complete, and failed
29 ZOOM::IRSpy - Perl extension for discovering and analysing IR services
34 $spy = new ZOOM::IRSpy("target/string/for/irspy/database");
35 print $spy->report_status();
39 This module exists to implement the IRspy program, which discovers,
40 analyses and monitors IR servers implementing the Z39.50 and SRU/W
41 protocols. It is a successor to the ZSpy program.
46 ZOOM::Log::mask_str("irspy");
47 ZOOM::Log::mask_str("irspy_test");
48 ZOOM::Log::mask_str("irspy_debug");
49 ZOOM::Log::mask_str("irspy_event");
50 ZOOM::Log::mask_str("irspy_unhandled");
55 my($dbname, $user, $password) = @_;
58 push @options, (user => $user, password => $password)
61 my $conn = new ZOOM::Connection($dbname, 0, @options)
62 or die "$0: can't connection to IRSpy database 'dbname'";
66 allrecords => 1, # unless overridden by targets()
67 query => undef, # filled in later
68 targets => undef, # filled in later
69 connections => undef, # filled in later
70 tests => [], # stack of tests currently being executed
72 $this->log("irspy", "starting up with database '$dbname'");
84 # Explicitly nominate a set of targets to check, overriding the
85 # default which is to re-check everything in the database. Each
86 # target already in the database results in the existing record being
87 # updated; each new target causes a new record to be added.
93 $this->log("irspy", "setting explicit list of targets ",
94 join(", ", map { "'$_'" } @targets));
95 $this->{allrecords} = 0;
97 foreach my $target (@targets) {
98 my($host, $port, $db, $newtarget) = _parse_target_string($target);
99 if ($newtarget ne $target) {
100 $this->log("irspy_debug", "rewriting '$target' to '$newtarget'");
101 $target = $newtarget; # This is written through the ref
103 push @qlist, (qq[(host="$host" and port="$port" and path="$db")]);
106 $this->{targets} = \@targets;
107 $this->{query} = join(" or ", @qlist);
111 # Also used by ZOOM::IRSpy::Record
112 sub _parse_target_string {
115 my($host, $port, $db) = ($target =~ /(.*?):(.*?)\/(.*)/);
116 if (!defined $host) {
118 ($host, $db) = ($target =~ /(.*?)\/(.*)/);
119 $target = "$host:$port/$db";
121 die "$0: invalid target string '$target'"
124 return ($host, $port, $db, $target);
128 # There are two cases.
130 # 1. A specific set of targets is nominated on the command line.
131 # - Records must be fetched for those targets that are in the DB
132 # - New, empty records must be made for those that are not.
133 # - Updated records written to the DB may or may not be new.
135 # 2. All records in the database are to be checked.
136 # - Records must be fetched for all targets in the DB
137 # - Updated records written to the DB may not be new.
139 # That's all -- what could be simpler?
145 if ($this->{allrecords}) {
146 # We need to check on every target in the database, which
147 # means we need to do a "find all". According to the BIB-1
148 # semantics document at
149 # http://www.loc.gov/z3950/agency/bib1.html
151 # @attr 2=103 @attr 1=1035 x
152 # should find all records, but it seems that Zebra doesn't
153 # support this. Furthermore, when using the "alvis" filter
154 # (as we do for IRSpy) it doesn't support the use of any BIB-1
155 # access point -- not even 1035 "everywhere" -- so instead we
156 # hack together a search that we know will find all records.
157 $this->{query} = "port=?*";
159 # Prepopulate the target map with nulls so that after we fill
160 # in what we can from the database query, we know which target
161 # IDs we need new records for.
162 foreach my $target (@{ $this->{targets} }) {
163 $target2record{lc($target)} = undef;
167 $this->log("irspy_debug", "query '", $this->{query}, "'");
168 my $rs = $this->{conn}->search(new ZOOM::Query::CQL($this->{query}));
169 delete $this->{query}; # No longer needed at all
170 $this->log("irspy_debug", "found ", $rs->size(), " target records");
171 foreach my $i (1 .. $rs->size()) {
172 my $target = _render_record($rs, $i-1, "id");
173 my $zeerex = _render_record($rs, $i-1, "zeerex");
174 #print STDERR "making '$target' record with '$zeerex'\n";
175 $target2record{lc($target)} =
176 new ZOOM::IRSpy::Record($this, $target, $zeerex);
177 push @{ $this->{targets} }, $target
178 if $this->{allrecords};
181 # Make records for targets not previously in the database
182 foreach my $target (keys %target2record) {
183 my $record = $target2record{$target};
184 if (!defined $record) {
185 $this->log("irspy_debug", "made new record for '$target'");
186 $target2record{$target} = new ZOOM::IRSpy::Record($this, $target);
188 $this->log("irspy_debug", "using existing record for '$target'");
193 foreach my $target (@{ $this->{targets} }) {
194 my $conn = new ZOOM::IRSpy::Connection($this, $target, 0, async => 1);
195 my $record = delete $target2record{lc($target)};
196 $conn->record($record);
197 push @connections, $conn;
199 die("remaining target2record = { " .
200 join(", ", map { "$_ ->'" . $target2record{$_}. "'" }
201 sort keys %target2record) . " }")
204 $this->{connections} = \@connections;
205 delete $this->{targets}; # The information is now in {connections}
210 my($rs, $which, $elementSetName) = @_;
212 # There is a slight race condition here on the element-set name,
213 # but it shouldn't be a problem as this is (currently) only called
214 # from parts of the program that run single-threaded.
215 my $old = $rs->option(elementSetName => $elementSetName);
216 my $rec = $rs->record($which);
217 $rs->option(elementSetName => $old);
219 return $rec->render();
223 sub _rewrite_records {
226 # Write modified records back to database
227 foreach my $conn (@{ $this->{connections} }) {
228 my $rec = $conn->record();
229 my $p = $this->{conn}->package();
230 $p->option(action => "specialUpdate");
231 my $xml = $rec->{zeerex}->toString();
232 $p->option(record => $xml);
236 $p = $this->{conn}->package();
243 print "Updated with xml=<br/>\n<pre>$xml</pre>\n";
250 # 1. Gather declarative information about test hierarchy.
251 # 2. For each connection, start the initial test -- invokes run().
252 # 3. Run each connection's first queued task.
253 # 4. while (1) { wait() }. Callbacks return a ZOOM::IRSpy::Status value
254 # No individual test ever calls wait: tests just set up tasks.
260 $tname = "Main" if !defined $tname;
261 $this->{tree} = $this->_gather_tests($tname)
262 or die "No tests defined";
263 #$this->{tree}->print(0);
265 my @conn = @{ $this->{connections} };
266 foreach my $conn (@conn) {
267 $this->_start_test($conn, "");
270 while ((my $i0 = ZOOM::event(\@conn)) != 0) {
271 my $conn = $conn[$i0-1];
272 my $target = $conn->option("host");
273 my $ev = $conn->last_event();
274 my $evstr = ZOOM::event_str($ev);
275 $this->log("irspy_event", "$target event $ev ($evstr)");
277 my $task = $conn->current_task();
282 # This is a nasty hack. An error in, say, a search response,
283 # becomes visible to ZOOM before the Receive Data event is
284 # sent and persists until after the End, which means that
285 # successive events each report the same error. So we
286 # just ignore errors on "unimportant" events. Let's hope
287 # this doesn't come back and bite us.
288 if ($ev == ZOOM::Event::RECV_DATA ||
289 $ev == ZOOM::Event::RECV_APDU ||
290 $ev == ZOOM::Event::ZEND) {
291 $this->log("irspy_event", "$target ignoring error ",
292 "on event $ev ($evstr): $@");
294 my $sub = $task->{cb}->{exception};
295 die $@ if !defined $sub;
296 $res = &$sub($conn, $task, $@);
301 my $sub = $task ? $task->{cb}->{$ev} : undef;
303 $conn->log("irspy_unhandled", "event $ev ($evstr)");
304 # Catch the case of a pure-container test ending
305 if ($ev == ZOOM::Event::ZEND && !$conn->current_task()) {
306 $conn->log("irspy", "last event, no task queued");
312 $res = &$sub($conn, $task, $ev);
314 if ($res == ZOOM::IRSpy::Status::OK) {
315 # Nothing to do -- life continues
317 } elsif ($res == ZOOM::IRSpy::Status::TASK_DONE) {
318 my $task = $conn->current_task();
319 die "can't happen" if !$task;
320 $conn->log("irspy", "completed task $task");
321 my $nexttask = $task->{next};
322 if (defined $nexttask) {
323 $conn->log("irspy_debug", "next task is '$nexttask'");
324 $conn->start_task($nexttask);
326 $conn->log("irspy_debug", "jumping to NEXT_TEST");
327 $conn->current_task(0);
331 } elsif ($res == ZOOM::IRSpy::Status::TEST_GOOD) {
332 $conn->log("irspy", "test completed (GOOD)");
334 my $address = $conn->option("address");
335 my $nextaddr = $this->_next_test($address);
336 if (defined $nextaddr) {
337 $this->_start_test($conn, $nextaddr);
339 $conn->log("irspy", "has no tests after '$address'");
340 # Nothing else to do: we will get no more meaningful
341 # events on this connection, and when all the
342 # connections have reached this state, ZOOM::event()
343 # will return 0 and we will fall out of the loop.
346 } elsif ($res == ZOOM::IRSpy::Status::TEST_BAD) {
347 $conn->log("irspy", "test completed (BAD)");
348 ### Should skip over remaining sibling tests
353 $this->log("irspy_event", "ZOOM::event() returned 0");
355 #$this->_rewrite_records();
356 return 0; # What does this mean?
361 # - called only when there no tasks remain for the connection
362 # - called with valid address
365 my($conn, $address) = @_;
367 my $task = $conn->current_task();
368 die "_start_test(): $conn already has task $task"
372 my $node = $this->{tree}->select($address)
373 or die "_start_test(): invalid address '$address'";
375 $conn->option(address => $address);
376 my $tname = $node->name();
377 $this->log("irspy", $conn->option("host"),
378 " starting test '$address' = $tname");
380 # We will need to find the first of the tasks that are added by
381 # the test we're about to start, so we can start that task. This
382 # requires a little trickery: noting the current length of the
383 # tasks array first, then fetching the next one off the end.
384 my $alltasks = $conn->tasks();
385 my $ntasks = defined $alltasks ? @$alltasks : 0;
386 my $test = "ZOOM::IRSpy::Test::$tname"->start($conn);
388 $alltasks = $conn->tasks();
389 if (defined $alltasks && @$alltasks > $ntasks) {
390 my $task = $alltasks->[$ntasks];
391 $conn->start_task($task);
393 $this->log("irspy", "no tasks added for test '$address' = $tname");
400 my($tname, @ancestors) = @_;
402 die("$0: test-hierarchy loop detected: " .
403 join(" -> ", @ancestors, $tname))
404 if grep { $_ eq $tname } @ancestors;
407 my $slashSeperatedTname = $tname;
408 $slashSeperatedTname =~ s/::/\//g;
409 require "ZOOM/IRSpy/Test/$slashSeperatedTname.pm";
411 $this->log("warn", "can't load test '$tname': skipping",
412 $@ =~ /^Can.t locate/ ? () : " ($@)");
416 $this->log("irspy", "adding test '$tname'");
418 foreach my $subtname ("ZOOM::IRSpy::Test::$tname"->subtests($this)) {
419 my $subtest = $this->_gather_tests($subtname, @ancestors, $tname);
420 push @subnodes, $subtest if defined $subtest;
423 return new ZOOM::IRSpy::Node($tname, @subnodes);
429 my($address, $omit_child) = @_;
431 $this->log("irspy", "checking for next test after '$address'");
435 my $maybe = $address eq "" ? "0" : "$address:0";
436 return $maybe if $this->{tree}->select($maybe);
439 # The top-level node has no successor or parent
440 return undef if $address eq "";
442 # Try next sibling child
443 my @components = split /:/, $address;
444 my $last = pop @components;
445 my $maybe = join(":", @components, $last+1);
446 return $maybe if $this->{tree}->select($maybe);
448 # This node is exhausted: try the parent's successor
449 return $this->_next_test(join(":", @components), 1)
458 ZOOM::IRSpy::Maintenance.
460 The ZOOM-Perl module,
461 http://search.cpan.org/~mirk/Net-Z3950-ZOOM/
464 http://indexdata.com/zebra/
468 Mike Taylor, E<lt>mike@indexdata.comE<gt>
470 =head1 COPYRIGHT AND LICENSE
472 Copyright (C) 2006 by Index Data ApS.
474 This library is free software; you can redistribute it and/or modify
475 it under the same terms as Perl itself, either Perl version 5.8.7 or,
476 at your option, any later version of Perl 5 you may have available.