lib/ZOOM/IRSpy/Connection.pm

   1
   2 package ZOOM::IRSpy::Connection;
   3
   4 use 5.008;
   5 use strict;
   6 use warnings;
   7
   8 use ZOOM;
   9 our @ISA = qw(ZOOM::Connection);
  10
  11 use ZOOM::IRSpy::Record;
  12 use ZOOM::IRSpy::Utils qw(cql_target render_record irspy_identifier2target);
  13
  14 use ZOOM::IRSpy::Task::Connect;
  15 use ZOOM::IRSpy::Task::Search;
  16 use ZOOM::IRSpy::Task::Retrieve;
  17
  18
  19 =head1 NAME
  20
  21 ZOOM::IRSpy::Connection - ZOOM::Connection subclass with IRSpy functionality
  22
  23 =head1 DESCRIPTION
  24
  25 This class provides some additional private data and methods that are
  26 used by IRSpy but which would be useless in any other application.
  27 Keeping the private data in these objects removes the need for ugly
  28 mappings in the IRSpy object itself; adding the methods makes the
  29 application code cleaner.
  30
  31 The constructor takes an two additional leading arguments: a reference
  32 to the IRSpy object that it is associated with, and the target ID of
  33 the connection.
  34
  35 =cut
  36
  37 sub create {
  38     my $class = shift();
  39     my $irspy = shift();
  40     my $id = shift();
  41
  42     my $this = $class->SUPER::create(@_);
  43     my $target = irspy_identifier2target($id);
  44     $this->option(host => $target);
  45     $this->{irspy} = $irspy;
  46     $this->{tasks} = [];
  47
  48     my $query = cql_target($id);
  49     my $rs;
  50     eval {
  51         $rs = $irspy->{conn}->search(new ZOOM::Query::CQL($query));
  52     }; if ($@) {
  53         # This should be a "can't happen", but junk entries such as
  54         #       //lucasportal.info/blogs/payday-usa">'</a>night:G<a href="http://lucasportal.info/blogs/payday-usa">'</a>night/Illepeliz
  55         # (yes, really) yield BIB-1 diagnostic 108 "Malformed query"
  56         warn "registry search for record '$id' had error: '$@' -- skipping";
  57         return undef;
  58     }
  59     my $n = $rs->size();
  60     $this->log("irspy", "query '$query' found $n record", $n==1 ? "" : "s");
  61     ### More than 1 hit is always an error and indicates duplicate
  62     #   records in the database; no hits is fine for a new target
  63     #   being probed for the first time, but not if the connection is
  64     #   being created as part of an "all known targets" scan.
  65     my $zeerex;
  66     $zeerex = render_record($rs, 0, "zeerex") if $n > 0;
  67     $this->{record} = new ZOOM::IRSpy::Record($this, $target, $zeerex);
  68
  69     return $this;
  70 }
  71
  72
  73 sub destroy {
  74     my $this = shift();
  75     $this->SUPER::destroy(@_);
  76 }
  77
  78
  79 sub irspy {
  80     my $this = shift();
  81     return $this->{irspy};
  82 }
  83
  84
  85 sub record {
  86     my $this = shift();
  87     my($new) = @_;
  88
  89     my $old = $this->{record};
  90     $this->{record} = $new if defined $new;
  91     return $old;
  92 }
  93
  94
  95 sub tasks {
  96     my $this = shift();
  97
  98     return $this->{tasks};
  99 }
 100
 101
 102 sub current_task {
 103     my $this = shift();
 104     my($new) = @_;
 105
 106     my $old = $this->{current_task};
 107     if (defined $new) {
 108         $this->{current_task} = $new;
 109         $this->log("irspy_task", "set current task to $new");
 110     }
 111
 112     return $old;
 113 }
 114
 115
 116 sub next_task {
 117     my $this = shift();
 118     my($new) = @_;
 119
 120     my $old = $this->{next_task};
 121     if (defined $new) {
 122         $this->{next_task} = $new;
 123         $this->log("irspy_task", "set next task to $new");
 124     }
 125
 126     return $old;
 127 }
 128
 129
 130 sub log {
 131     my $this = shift();
 132     my($level, @msg) = @_;
 133
 134     $this->irspy()->log($level, $this->option("host"), " ", @msg);
 135 }
 136
 137
 138 sub irspy_connect {
 139     my $this = shift();
 140     my($udata, $options, %cb) = @_;
 141
 142     $this->add_task(new ZOOM::IRSpy::Task::Connect
 143                     ($this, $udata, $options, %cb));
 144 }
 145
 146
 147 sub irspy_search {
 148     my $this = shift();
 149     my($qtype, $qstr, $udata, $options, %cb) = @_;
 150
 151     { use Carp; confess "Odd-sized hash!" if @_ % 2; }
 152     #warn "calling $this->irspy_search(", join(", ", @_), ")\n";
 153     $this->add_task(new ZOOM::IRSpy::Task::Search
 154                     ($qtype, $qstr, $this, $udata, $options, %cb));
 155 }
 156
 157
 158 # Wrapper for backwards compatibility
 159 sub irspy_search_pqf {
 160     my $this = shift();
 161     return $this->irspy_search("pqf", @_);
 162 }
 163
 164
 165 sub irspy_rs_record {
 166     my $this = shift();
 167     my($rs, $index0, $udata, $options, %cb) = @_;
 168
 169     $this->add_task(new ZOOM::IRSpy::Task::Retrieve
 170                     ($rs, $index0, $this, $udata, $options, %cb));
 171 }
 172
 173
 174 sub add_task {
 175     my $this = shift();
 176     my($task) = @_;
 177
 178     my $tasks = $this->{tasks};
 179     $tasks->[-1]->{next} = $task if @$tasks > 0;
 180     push @$tasks, $task;
 181     $this->log("irspy_task", "added task $task");
 182 }
 183
 184
 185 sub render {
 186     my $this = shift();
 187     return ref($this) . "(" . $this->option("host") . ")";
 188 }
 189
 190 use overload '""' => \&render;
 191
 192
 193 =head1 SEE ALSO
 194
 195 ZOOM::IRSpy
 196
 197 =head1 AUTHOR
 198
 199 Mike Taylor, E<lt>mike@indexdata.comE<gt>
 200
 201 =head1 COPYRIGHT AND LICENSE
 202
 203 Copyright (C) 2006 by Index Data ApS.
 204
 205 This library is free software; you can redistribute it and/or modify
 206 it under the same terms as Perl itself, either Perl version 5.8.7 or,
 207 at your option, any later version of Perl 5 you may have available.
 208
 209 =cut
 210
 211 1;