Slightly more explicit logging.
[irspy-moved-to-github.git] / lib / ZOOM / IRSpy.pm
1 # $Id: IRSpy.pm,v 1.3 2006-06-20 16:32:03 mike Exp $
2
3 package ZOOM::IRSpy;
4
5 use 5.008;
6 use strict;
7 use warnings;
8 use ZOOM::IRSpy::Record;
9 use ZOOM::Pod;
10
11 our @ISA = qw();
12 our $VERSION = '0.02';
13
14 =head1 NAME
15
16 ZOOM::IRSpy - Perl extension for discovering and analysing IR services
17
18 =head1 SYNOPSIS
19
20  use ZOOM::IRSpy;
21  $spy = new ZOOM::IRSpy("target/string/for/irspy/database");
22  print $spy->report_status();
23
24 =head1 DESCRIPTION
25
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.
29
30 =cut
31
32 BEGIN { ZOOM::Log::mask_str("irspy") }
33
34 sub new {
35     my $class = shift();
36     my($dbname) = @_;
37
38     my $conn = new ZOOM::Connection($dbname)
39         or die "$0: can't connection to IRSpy database 'dbname'";
40
41     my $this = bless {
42         conn => $conn,
43         allrecords => 1,        # unless overridden by targets()
44         # query and targets will be filled in later
45     }, $class;
46     $this->log("irspy", "starting up with database '$dbname'");
47
48     return $this;
49 }
50
51
52 sub log {
53     my $this = shift();
54     ZOOM::Log::log(@_);
55 }
56
57
58 # Explicitly nominate a set of targets to check, overriding the
59 # default which is to re-check everything in the database.  Each
60 # target already in the database results in the existing record being
61 # updated; each new target causes a new record to be added.
62 #
63 sub targets {
64     my $this = shift();
65     my($targetList) = @_;
66
67     $this->log("irspy", "setting explicit list of targets '$targetList'");
68     $this->{allrecords} = 0;
69     my @targets = split /\s+/, $targetList;
70     my @qlist;
71     foreach my $target (@targets) {
72         my($host, $port, $db) = ($target =~ /(.*?):(.*?)\/(.*)/);
73         if (!defined $host) {
74             $port = 210;
75             ($host, $db) = ($target =~ /(.*?)\/(.*)/);
76             $this->log("irspy", "rewrote '$target' to '$host:$port/$db'");
77             $target = "$host:$port/$db";
78         }
79         die "invalid target string '$target'"
80             if !defined $host;
81         push @qlist,
82             (qq[(host = "$host" and port = "$port" and path="$db")]);
83     }
84
85     $this->{targets} = \@targets;
86     $this->{query} = join(" or ", @qlist);
87 }
88
89
90 # There are two cases.
91 #
92 # 1. A specific set of targets is nominated on the command line.
93 #       - Records must be fetched for those targets that are in the DB
94 #       - New, empty records must be made for those that are not.
95 #       - Updated records written to the DB may or may not be new.
96 #
97 # 2. All records in the database are to be checked.
98 #       - Records must be fetched for all targets in the DB
99 #       - Updated records written to the DB may not be new.
100 #
101 # That's all -- what could be simpler?
102 #
103 sub initialise {
104     my $this = shift();
105
106     my %target2record;
107     if ($this->{allrecords}) {
108         # We need to check on every target in the database, which
109         # means we need to do a "find all".  According to the BIB-1
110         # semantics document at
111         #       http://www.loc.gov/z3950/agency/bib1.html
112         # the query
113         #       @attr 2=103 @attr 1=1035 x
114         # should find all records, but it seems that Zebra doesn't
115         # support this.  Furthermore, when using the "alvis" filter
116         # (as we do for IRSpy) it doesn't support the use of any BIB-1
117         # access point -- not even 1035 "everywhere" -- so instead we
118         # hack together a search that we know will find all records.
119         $this->{query} = "port=?*";
120     } else {
121         # Prepopulate the target map with nulls so that after we fill
122         # in what we can from the database query, we know which target
123         # IDs we need new records for.
124         foreach my $target (@{ $this->{targets} }) {
125             $target2record{lc($target)} = undef;
126         }
127     }
128
129     my $rs = $this->{conn}->search(new ZOOM::Query::CQL($this->{query}));
130     foreach my $i (1 .. $rs->size()) {
131         my $target = _render_record($rs, $i-1, "id");
132         my $zeerex = _render_record($rs, $i-1, "zeerex");
133         $target2record{lc($target)} =
134             new ZOOM::IRSpy::Record($target, $zeerex);
135     }
136
137     foreach my $target (keys %target2record) {
138         my $record = $target2record{$target};
139         if (!defined $record) {
140             $this->log("irspy", "made new record for '$target'");
141             $target2record{$target} = new ZOOM::IRSpy::Record($target);
142         } else {
143             $this->log("irspy", "using existing record for '$target'");
144         }
145     }
146
147     $this->{pod} = new ZOOM::Pod(@{ $this->{targets} });
148 }
149
150
151 sub _render_record {
152     my($rs, $which, $elementSetName) = @_;
153
154     # There is a slight race condition here on the element-set name,
155     # but it shouldn't be a problem as this is (currently) only called
156     # from parts of the program that run single-threaded.
157     my $old = $rs->option(elementSetName => $elementSetName);
158     my $rec = $rs->record($which);
159     $rs->option(elementSetName => $old);
160
161     return $rec->render();
162 }
163
164
165 # Returns:
166 #       0 all tests successfully run
167 #       1 some tests skipped
168 #
169 sub check {
170     my $this = shift();
171
172     return $this->_run_test("Main");
173 }
174
175
176 sub _run_test {
177     my $this = shift();
178     my($tname) = @_;
179
180     eval {
181         require "ZOOM/IRSpy/Test/$tname.pm";
182     }; if ($@) {
183         $this->log("warn", "can't load test '$tname': skipping",
184                    $@ =~ /^Can.t locate/ ? () : " ($@)");
185         return 1;
186     }
187
188     $this->log("irspy", "running test '$tname'");
189     my $test = "ZOOM::IRSpy::Test::$tname"->new($this);
190     return $test->run();
191 }
192
193
194 =head1 SEE ALSO
195
196 ZOOM::IRSpy::Record
197
198 The ZOOM-Perl module,
199 http://search.cpan.org/~mirk/Net-Z3950-ZOOM/
200
201 The Zebra Database,
202 http://indexdata.com/zebra/
203
204 =head1 AUTHOR
205
206 Mike Taylor, E<lt>mike@indexdata.comE<gt>
207
208 =head1 COPYRIGHT AND LICENSE
209
210 Copyright (C) 2006 by Index Data ApS.
211
212 This library is free software; you can redistribute it and/or modify
213 it under the same terms as Perl itself, either Perl version 5.8.7 or,
214 at your option, any later version of Perl 5 you may have available.
215
216 =cut
217
218 1;