# $Id: IRSpy.pm,v 1.21 2006-09-27 12:49:46 mike Exp $
package ZOOM::IRSpy;
use 5.008;
use strict;
use warnings;
use ZOOM::IRSpy::Record;
use ZOOM::Pod;
our @ISA = qw();
our $VERSION = '0.02';
=head1 NAME
ZOOM::IRSpy - Perl extension for discovering and analysing IR services
=head1 SYNOPSIS
use ZOOM::IRSpy;
$spy = new ZOOM::IRSpy("target/string/for/irspy/database");
print $spy->report_status();
=head1 DESCRIPTION
This module exists to implement the IRspy program, which discovers,
analyses and monitors IR servers implementing the Z39.50 and SRU/W
protocols. It is a successor to the ZSpy program.
=cut
BEGIN {
ZOOM::Log::mask_str("irspy");
ZOOM::Log::mask_str("irspy_test");
ZOOM::Log::mask_str("irspy_debug");
}
sub new {
my $class = shift();
my($dbname, $user, $password) = @_;
my @options;
push @options, (user => $user, password => $password)
if defined $user;
my $conn = new ZOOM::Connection($dbname, 0, @options)
or die "$0: can't connection to IRSpy database 'dbname'";
my $this = bless {
conn => $conn,
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
tests => [], # stack of tests currently being executed
}, $class;
$this->log("irspy", "starting up with database '$dbname'");
return $this;
}
sub log {
my $this = shift();
ZOOM::Log::log(@_);
}
# Explicitly nominate a set of targets to check, overriding the
# default which is to re-check everything in the database. Each
# target already in the database results in the existing record being
# updated; each new target causes a new record to be added.
#
sub targets {
my $this = shift();
my(@targets) = @_;
$this->log("irspy", "setting explicit list of targets ",
join(", ", map { "'$_'" } @targets));
$this->{allrecords} = 0;
my @qlist;
foreach my $target (@targets) {
my($host, $port, $db, $newtarget) = _parse_target_string($target);
if ($newtarget ne $target) {
$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")]);
}
$this->{targets} = \@targets;
$this->{query} = join(" or ", @qlist);
}
# Also used by ZOOM::IRSpy::Record
sub _parse_target_string {
my($target) = @_;
my($host, $port, $db) = ($target =~ /(.*?):(.*?)\/(.*)/);
if (!defined $host) {
$port = 210;
($host, $db) = ($target =~ /(.*?)\/(.*)/);
$target = "$host:$port/$db";
}
die "$0: invalid target string '$target'"
if !defined $host;
return ($host, $port, $db, $target);
}
# There are two cases.
#
# 1. A specific set of targets is nominated on the command line.
# - Records must be fetched for those targets that are in the DB
# - New, empty records must be made for those that are not.
# - Updated records written to the DB may or may not be new.
#
# 2. All records in the database are to be checked.
# - Records must be fetched for all targets in the DB
# - Updated records written to the DB may not be new.
#
# That's all -- what could be simpler?
#
sub initialise {
my $this = shift();
my %target2record;
if ($this->{allrecords}) {
# We need to check on every target in the database, which
# means we need to do a "find all". According to the BIB-1
# semantics document at
# http://www.loc.gov/z3950/agency/bib1.html
# the query
# @attr 2=103 @attr 1=1035 x
# should find all records, but it seems that Zebra doesn't
# support this. Furthermore, when using the "alvis" filter
# (as we do for IRSpy) it doesn't support the use of any BIB-1
# access point -- not even 1035 "everywhere" -- so instead we
# hack together a search that we know will find all records.
$this->{query} = "port=?*";
} else {
# Prepopulate the target map with nulls so that after we fill
# in what we can from the database query, we know which target
# IDs we need new records for.
foreach my $target (@{ $this->{targets} }) {
$target2record{lc($target)} = undef;
}
}
my $rs = $this->{conn}->search(new ZOOM::Query::CQL($this->{query}));
#print "size='", $rs->size(), "'\n";
foreach my $i (1 .. $rs->size()) {
my $target = _render_record($rs, $i-1, "id");
my $zeerex = _render_record($rs, $i-1, "zeerex");
#print STDERR "making '$target' record with '$zeerex'\n";
$target2record{lc($target)} =
new ZOOM::IRSpy::Record($this, $target, $zeerex);
push @{ $this->{targets} }, $target
if $this->{allrecords};
}
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
}
sub _render_record {
my($rs, $which, $elementSetName) = @_;
# There is a slight race condition here on the element-set name,
# but it shouldn't be a problem as this is (currently) only called
# from parts of the program that run single-threaded.
my $old = $rs->option(elementSetName => $elementSetName);
my $rec = $rs->record($which);
$rs->option(elementSetName => $old);
return $rec->render();
}
# Returns:
# 0 all tests successfully run
# 1 some tests skipped
#
sub check {
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
my $p = $this->{conn}->package();
$p->option(action => "specialUpdate");
my $xml = $rec->{zeerex}->toString();
$p->option(record => $xml);
$p->send("update");
$p->destroy();
$p = $this->{conn}->package();
$p->send("commit");
$p->destroy();
if (0) {
$xml =~ s/&/&/g;
$xml =~ s/</g;
$xml =~ s/>/>/g;
print "Updated with xml=
\n
$xml\n"; } } return $res; } sub _run_test { my $this = shift(); my($tname) = @_; die("$0: test-hierarchy loop detected: " . join(" -> ", @{ $this->{tests} }, $tname)) if grep { $_ eq $tname } @{ $this->{tests} }; eval { my $slashSeperatedTname = $tname; $slashSeperatedTname =~ s/::/\//g; require "ZOOM/IRSpy/Test/$slashSeperatedTname.pm"; }; if ($@) { $this->log("warn", "can't load test '$tname': skipping", $@ =~ /^Can.t locate/ ? () : " ($@)"); return 1; } $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; } # Access methods for the use of Test modules sub pod { my $this = shift(); return $this->{pod}; } sub record { my $this = shift(); my($target) = @_; 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"); } return $this->{target2record}->{lc($target)}; } # 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); } =head1 SEE ALSO ZOOM::IRSpy::Record, ZOOM::IRSpy::Web, ZOOM::IRSpy::Test, ZOOM::IRSpy::Maintenance. The ZOOM-Perl module, http://search.cpan.org/~mirk/Net-Z3950-ZOOM/ The Zebra Database, http://indexdata.com/zebra/ =head1 AUTHOR Mike Taylor, E