1 # $Id: IRSpy.pm,v 1.12 2006-07-25 15:18:03 mike Exp $
8 use ZOOM::IRSpy::Record;
12 our $VERSION = '0.02';
16 ZOOM::IRSpy - Perl extension for discovering and analysing IR services
21 $spy = new ZOOM::IRSpy("target/string/for/irspy/database");
22 print $spy->report_status();
26 This module exists to implement the IRspy program, which discovers,
27 analyses and monitors IR servers implementing the Z39.50 and SRU/W
28 protocols. It is a successor to the ZSpy program.
33 ZOOM::Log::mask_str("irspy");
34 ZOOM::Log::mask_str("irspy_test");
35 ZOOM::Log::mask_str("irspy_debug");
42 my $conn = new ZOOM::Connection($dbname)
43 or die "$0: can't connection to IRSpy database 'dbname'";
47 allrecords => 1, # unless overridden by targets()
48 query => undef, # filled in later
49 targets => undef, # filled in later
50 target2record => undef, # filled in later
51 pod => undef, # filled in later
52 tests => [], # stack of tests currently being executed
54 $this->log("irspy", "starting up with database '$dbname'");
66 # Explicitly nominate a set of targets to check, overriding the
67 # default which is to re-check everything in the database. Each
68 # target already in the database results in the existing record being
69 # updated; each new target causes a new record to be added.
75 $this->log("irspy", "setting explicit list of targets '$targetList'");
76 $this->{allrecords} = 0;
77 my @targets = split /\s+/, $targetList;
79 foreach my $target (@targets) {
80 my($host, $port, $db, $newtarget) = _parse_target_string($target);
81 if ($newtarget ne $target) {
82 $this->log("irspy_debug", "rewriting '$target' to '$newtarget'");
83 $target = $newtarget; # This written through the ref
86 (qq[(host = "$host" and port = "$port" and path="$db")]);
89 $this->{targets} = \@targets;
90 $this->{query} = join(" or ", @qlist);
94 # Also used by ZOOM::IRSpy::Record
95 sub _parse_target_string {
98 my($host, $port, $db) = ($target =~ /(.*?):(.*?)\/(.*)/);
101 ($host, $db) = ($target =~ /(.*?)\/(.*)/);
102 $target = "$host:$port/$db";
104 die "$0: invalid target string '$target'"
107 return ($host, $port, $db, $target);
111 # There are two cases.
113 # 1. A specific set of targets is nominated on the command line.
114 # - Records must be fetched for those targets that are in the DB
115 # - New, empty records must be made for those that are not.
116 # - Updated records written to the DB may or may not be new.
118 # 2. All records in the database are to be checked.
119 # - Records must be fetched for all targets in the DB
120 # - Updated records written to the DB may not be new.
122 # That's all -- what could be simpler?
128 if ($this->{allrecords}) {
129 # We need to check on every target in the database, which
130 # means we need to do a "find all". According to the BIB-1
131 # semantics document at
132 # http://www.loc.gov/z3950/agency/bib1.html
134 # @attr 2=103 @attr 1=1035 x
135 # should find all records, but it seems that Zebra doesn't
136 # support this. Furthermore, when using the "alvis" filter
137 # (as we do for IRSpy) it doesn't support the use of any BIB-1
138 # access point -- not even 1035 "everywhere" -- so instead we
139 # hack together a search that we know will find all records.
140 $this->{query} = "port=?*";
142 # Prepopulate the target map with nulls so that after we fill
143 # in what we can from the database query, we know which target
144 # IDs we need new records for.
145 foreach my $target (@{ $this->{targets} }) {
146 $target2record{lc($target)} = undef;
150 my $rs = $this->{conn}->search(new ZOOM::Query::CQL($this->{query}));
151 foreach my $i (1 .. $rs->size()) {
152 my $target = _render_record($rs, $i-1, "id");
153 my $zeerex = _render_record($rs, $i-1, "zeerex");
154 $target2record{lc($target)} =
155 new ZOOM::IRSpy::Record($target, $zeerex);
156 push @{ $this->{targets} }, $target
157 if $this->{allrecords};
160 foreach my $target (keys %target2record) {
161 my $record = $target2record{$target};
162 if (!defined $record) {
163 $this->log("irspy_debug", "made new record for '$target'");
164 $target2record{$target} = new ZOOM::IRSpy::Record($target);
166 $this->log("irspy_debug", "using existing record for '$target'");
170 $this->{target2record} = \%target2record;
171 $this->{pod} = new ZOOM::Pod(@{ $this->{targets} });
172 delete $this->{targets}; # The information is now in the Pod.
173 delete $this->{query}; # Not needed at all
178 my($rs, $which, $elementSetName) = @_;
180 # There is a slight race condition here on the element-set name,
181 # but it shouldn't be a problem as this is (currently) only called
182 # from parts of the program that run single-threaded.
183 my $old = $rs->option(elementSetName => $elementSetName);
184 my $rec = $rs->record($which);
185 $rs->option(elementSetName => $old);
187 return $rec->render();
192 # 0 all tests successfully run
193 # 1 some tests skipped
198 my $res = $this->_run_test("Main");
199 foreach my $target (sort keys %{ $this->{target2record} }) {
200 my $rec = $this->{target2record}->{$target};
201 print STDERR "$target: zeerex='", $rec->{zeerex}, "' = \n",
202 $rec->{zeerex}->toString(), "\n";
203 ### Write record back to database, if modified.
214 die("$0: test-hierarchy loop detected: " .
215 join(" -> ", @{ $this->{tests} }, $tname))
216 if grep { $_ eq $tname } @{ $this->{tests} };
219 my $slashSeperatedTname = $tname;
220 $slashSeperatedTname =~ s/::/\//g;
221 require "ZOOM/IRSpy/Test/$slashSeperatedTname.pm";
223 $this->log("warn", "can't load test '$tname': skipping",
224 $@ =~ /^Can.t locate/ ? () : " ($@)");
228 $this->log("irspy", "running test '$tname'");
229 push @{ $this->{tests} }, $tname;
230 my $test = "ZOOM::IRSpy::Test::$tname"->new($this);
231 my $res =$test->run();
232 pop @{ $this->{tests} };
237 # Access methods for the use of Test modules
247 if (ref($target) && $target->isa("ZOOM::Connection")) {
248 # Can be called with a Connection instead of a target-name
250 $target = $conn->option("host");
253 return $this->{target2record}->{lc($target)};
257 # Utility method, really nothing to do with IRSpy
262 my($sec, $min, $hour, $mday, $mon, $year) = localtime($time);
263 return sprintf("%04d-%02d-%02dT%02d:%02d:%02d",
264 $year+1900, $mon+1, $mday, $hour, $min, $sec);
272 The ZOOM-Perl module,
273 http://search.cpan.org/~mirk/Net-Z3950-ZOOM/
276 http://indexdata.com/zebra/
280 Mike Taylor, E<lt>mike@indexdata.comE<gt>
282 =head1 COPYRIGHT AND LICENSE
284 Copyright (C) 2006 by Index Data ApS.
286 This library is free software; you can redistribute it and/or modify
287 it under the same terms as Perl itself, either Perl version 5.8.7 or,
288 at your option, any later version of Perl 5 you may have available.