lib/ZOOM/IRSpy.pm

   1 # $Id: IRSpy.pm,v 1.22 2006-10-06 11:33:07 mike Exp $
   2
   3 package ZOOM::IRSpy;
   4
   5 use 5.008;
   6 use strict;
   7 use warnings;
   8
   9 use Data::Dumper; # For debugging only
  10 use ZOOM::IRSpy::Node;
  11 use ZOOM::IRSpy::Connection;
  12 use ZOOM::IRSpy::Record;
  13
  14 our @ISA = qw();
  15 our $VERSION = '0.02';
  16
  17
  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
  24 package ZOOM::IRSpy;
  25
  26
  27 =head1 NAME
  28
  29 ZOOM::IRSpy - Perl extension for discovering and analysing IR services
  30
  31 =head1 SYNOPSIS
  32
  33  use ZOOM::IRSpy;
  34  $spy = new ZOOM::IRSpy("target/string/for/irspy/database");
  35  print $spy->report_status();
  36
  37 =head1 DESCRIPTION
  38
  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.
  42
  43 =cut
  44
  45 BEGIN {
  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");
  51 }
  52
  53 sub new {
  54     my $class = shift();
  55     my($dbname, $user, $password) = @_;
  56
  57     my @options;
  58     push @options, (user => $user, password => $password)
  59         if defined $user;
  60
  61     my $conn = new ZOOM::Connection($dbname, 0, @options)
  62         or die "$0: can't connection to IRSpy database 'dbname'";
  63
  64     my $this = bless {
  65         conn => $conn,
  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
  71     }, $class;
  72     $this->log("irspy", "starting up with database '$dbname'");
  73
  74     return $this;
  75 }
  76
  77
  78 sub log {
  79     my $this = shift();
  80     ZOOM::Log::log(@_);
  81 }
  82
  83
  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.
  88 #
  89 sub targets {
  90     my $this = shift();
  91     my(@targets) = @_;
  92
  93     $this->log("irspy", "setting explicit list of targets ",
  94                join(", ", map { "'$_'" } @targets));
  95     $this->{allrecords} = 0;
  96     my @qlist;
  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
 102         }
 103         push @qlist, (qq[(host="$host" and port="$port" and path="$db")]);
 104     }
 105
 106     $this->{targets} = \@targets;
 107     $this->{query} = join(" or ", @qlist);
 108 }
 109
 110
 111 # Also used by ZOOM::IRSpy::Record
 112 sub _parse_target_string {
 113     my($target) = @_;
 114
 115     my($host, $port, $db) = ($target =~ /(.*?):(.*?)\/(.*)/);
 116     if (!defined $host) {
 117         $port = 210;
 118         ($host, $db) = ($target =~ /(.*?)\/(.*)/);
 119         $target = "$host:$port/$db";
 120     }
 121     die "$0: invalid target string '$target'"
 122         if !defined $host;
 123
 124     return ($host, $port, $db, $target);
 125 }
 126
 127
 128 # There are two cases.
 129 #
 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.
 134 #
 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.
 138 #
 139 # That's all -- what could be simpler?
 140 #
 141 sub initialise {
 142     my $this = shift();
 143
 144     my %target2record;
 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
 150         # the query
 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=?*";
 158     } else {
 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;
 164         }
 165     }
 166
 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};
 179     }
 180
 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);
 187         } else {
 188             $this->log("irspy_debug", "using existing record for '$target'");
 189         }
 190     }
 191
 192     my @connections;
 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;
 198     }
 199     die("remaining target2record = { " .
 200         join(", ", map { "$_ ->'" . $target2record{$_}. "'" }
 201              sort keys %target2record) . " }")
 202         if %target2record;
 203
 204     $this->{connections} = \@connections;
 205     delete $this->{targets};    # The information is now in {connections}
 206 }
 207
 208
 209 sub _render_record {
 210     my($rs, $which, $elementSetName) = @_;
 211
 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);
 218
 219     return $rec->render();
 220 }
 221
 222
 223 sub _rewrite_records {
 224     my $this = shift();
 225
 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);
 233         $p->send("update");
 234         $p->destroy();
 235
 236         $p = $this->{conn}->package();
 237         $p->send("commit");
 238         $p->destroy();
 239         if (0) {
 240             $xml =~ s/&/&amp/g;
 241             $xml =~ s/</&lt;/g;
 242             $xml =~ s/>/&gt;/g;
 243             print "Updated with xml=<br/>\n<pre>$xml</pre>\n";
 244         }
 245     }
 246 }
 247
 248
 249 # New approach:
 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.
 255 #
 256 sub check {
 257     my $this = shift();
 258     my($tname) = @_;
 259
 260     $tname = "Main" if !defined $tname;
 261     $this->{tree} = $this->_gather_tests($tname)
 262         or die "No tests defined";
 263     #$this->{tree}->print(0);
 264
 265     my @conn = @{ $this->{connections} };
 266     foreach my $conn (@conn) {
 267         $this->_start_test($conn, "");
 268     }
 269
 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)");
 276
 277         my $task = $conn->current_task();
 278         my $res;
 279         eval {
 280             $conn->_check();
 281         }; if ($@) {
 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): $@");
 293             } else {
 294                 my $sub = $task->{cb}->{exception};
 295                 die $@ if !defined $sub;
 296                 $res = &$sub($conn, $task, $@);
 297                 goto HANDLE_RESULT;
 298             }
 299         }
 300
 301         my $sub = $task ? $task->{cb}->{$ev} : undef;
 302         if (!defined $sub) {
 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");
 307                 goto NEXT_TEST;
 308             }
 309             next;
 310         }
 311
 312         $res = &$sub($conn, $task, $ev);
 313       HANDLE_RESULT:
 314         if ($res == ZOOM::IRSpy::Status::OK) {
 315             # Nothing to do -- life continues
 316
 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);
 325             } else {
 326                 $conn->log("irspy_debug", "jumping to NEXT_TEST");
 327                 $conn->current_task(0);
 328                 goto NEXT_TEST;
 329             }
 330
 331         } elsif ($res == ZOOM::IRSpy::Status::TEST_GOOD) {
 332             $conn->log("irspy", "test completed (GOOD)");
 333           NEXT_TEST:
 334             my $address = $conn->option("address");
 335             my $nextaddr = $this->_next_test($address);
 336             if (defined $nextaddr) {
 337                 $this->_start_test($conn, $nextaddr);
 338             } else {
 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.
 344             }
 345
 346         } elsif ($res == ZOOM::IRSpy::Status::TEST_BAD) {
 347             $conn->log("irspy", "test completed (BAD)");
 348             ### Should skip over remaining sibling tests
 349             goto NEXT_TEST;
 350         }
 351     }
 352
 353     $this->log("irspy_event", "ZOOM::event() returned 0");
 354
 355     #$this->_rewrite_records();
 356     return 0;                   # What does this mean?
 357 }
 358
 359
 360 # Preconditions:
 361 # - called only when there no tasks remain for the connection
 362 # - called with valid address
 363 sub _start_test {
 364     my $this = shift();
 365     my($conn, $address) = @_;
 366     {
 367         my $task = $conn->current_task();
 368         die "_start_test(): $conn already has task $task"
 369             if $task;
 370     }
 371
 372     my $node = $this->{tree}->select($address)
 373         or die "_start_test(): invalid address '$address'";
 374
 375     $conn->option(address => $address);
 376     my $tname = $node->name();
 377     $this->log("irspy", $conn->option("host"),
 378                " starting test '$address' = $tname");
 379
 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);
 387
 388     $alltasks = $conn->tasks();
 389     if (defined $alltasks && @$alltasks > $ntasks) {
 390         my $task = $alltasks->[$ntasks];
 391         $conn->start_task($task);
 392     } else {
 393         $this->log("irspy", "no tasks added for test '$address' = $tname");
 394     }
 395 }
 396
 397
 398 sub _gather_tests {
 399     my $this = shift();
 400     my($tname, @ancestors) = @_;
 401
 402     die("$0: test-hierarchy loop detected: " .
 403         join(" -> ", @ancestors, $tname))
 404         if grep { $_ eq $tname } @ancestors;
 405
 406     eval {
 407         my $slashSeperatedTname = $tname;
 408         $slashSeperatedTname =~ s/::/\//g;
 409         require "ZOOM/IRSpy/Test/$slashSeperatedTname.pm";
 410     }; if ($@) {
 411         $this->log("warn", "can't load test '$tname': skipping",
 412                    $@ =~ /^Can.t locate/ ? () : " ($@)");
 413         return undef;
 414     }
 415
 416     $this->log("irspy", "adding test '$tname'");
 417     my @subtests;
 418     foreach my $subtname ("ZOOM::IRSpy::Test::$tname"->subtests($this)) {
 419         my $subtest = $this->_gather_tests($subtname, @ancestors, $tname);
 420         push @subtests, $subtest if defined $subtest;
 421     }
 422
 423     return new ZOOM::IRSpy::Node($tname, @subtests);
 424 }
 425
 426
 427 sub _next_test {
 428     my $this = shift();
 429     my($address, $omit_child) = @_;
 430
 431     $this->log("irspy", "checking for next test after '$address'");
 432
 433     # Try first child
 434     if (!$omit_child) {
 435         my $maybe = $address eq "" ? "0" : "$address:0";
 436         return $maybe if $this->{tree}->select($maybe);
 437     }
 438
 439     # The top-level node has no successor or parent
 440     return undef if $address eq "";
 441
 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);
 447
 448     # This node is exhausted: try the parent's successor
 449     return $this->_next_test(join(":", @components), 1)
 450 }
 451
 452
 453 =head1 SEE ALSO
 454
 455 ZOOM::IRSpy::Record,
 456 ZOOM::IRSpy::Web,
 457 ZOOM::IRSpy::Test,
 458 ZOOM::IRSpy::Maintenance.
 459
 460 The ZOOM-Perl module,
 461 http://search.cpan.org/~mirk/Net-Z3950-ZOOM/
 462
 463 The Zebra Database,
 464 http://indexdata.com/zebra/
 465
 466 =head1 AUTHOR
 467
 468 Mike Taylor, E<lt>mike@indexdata.comE<gt>
 469
 470 =head1 COPYRIGHT AND LICENSE
 471
 472 Copyright (C) 2006 by Index Data ApS.
 473
 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.
 477
 478 =cut
 479
 480
 481 1;