C4/Z3950.pm

   1 #!/usr/bin/perl
   2
   3 # $Id$
   4
   5 package C4::Z3950;
   6
   7 # Routines for handling Z39.50 lookups
   8
   9 # Koha library project  www.koha.org
  10
  11 # Licensed under the GPL
  12
  13 use strict;
  14
  15 # standard or CPAN modules used
  16 use DBI;
  17
  18 # Koha modules used
  19 use C4::Database;
  20 use C4::Input;
  21 use C4::Biblio;
  22
  23 #------------------
  24
  25 require Exporter;
  26
  27 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  28
  29 # set the version for version checking
  30 $VERSION = 0.01;
  31
  32 @ISA = qw(Exporter);
  33 @EXPORT = qw(
  34          &z3950servername
  35          &addz3950queue
  36 );
  37 %EXPORT_TAGS = ( );     # eg: TAG => [ qw!name1 name2! ],
  38
  39 # your exported package globals go here,
  40 # as well as any optionally exported functions
  41
  42 @EXPORT_OK   = qw($Var1 %Hashit);
  43
  44 # non-exported package globals go here
  45 use vars qw(@more $stuff);
  46
  47 # initalize package globals, first exported ones
  48
  49 my $Var1   = '';
  50 my %Hashit = ();
  51
  52 # then the others (which are still accessible as $Some::Module::stuff)
  53 my $stuff  = '';
  54 my @more   = ();
  55
  56 # all file-scoped lexicals must be created before
  57 # the functions below that use them.
  58
  59 # file-private lexicals go here
  60 my $priv_var    = '';
  61 my %secret_hash = ();
  62
  63 # here's a file-private function as a closure,
  64 # callable as &$priv_func;  it cannot be prototyped.
  65 my $priv_func = sub {
  66   # stuff goes here.
  67   };
  68
  69 # make all your functions, whether exported or not;
  70 #------------------------------------------------
  71
  72
  73 sub z3950servername {
  74     # inputs
  75     my (
  76         $dbh,
  77         $srvid,         # server id number
  78         $default,
  79     )=@_;
  80     # return
  81     my $longname;
  82     #----
  83
  84     requireDBI($dbh,"z3950servername");
  85
  86         my $sti=$dbh->prepare("select name
  87                 from z3950servers
  88                 where id=?");
  89         $sti->execute($srvid);
  90         if ( ! $sti->err ) {
  91             ($longname)=$sti->fetchrow;
  92         }
  93         if (! $longname) {
  94             $longname="$default";
  95         }
  96         return $longname;
  97 } # sub z3950servername
  98
  99 #---------------------------------------
 100 sub addz3950queue {
 101     use strict;
 102     # input
 103     my (
 104         $dbh,           # DBI handle
 105         $query,         # value to look up
 106         $type,          # type of value ("isbn", "lccn", etc).
 107         $requestid,     # Unique value to prevent duplicate searches from multiple HTML form submits
 108         @z3950list,     # list of z3950 servers to query
 109     )=@_;
 110     # Returns:
 111     my $error;
 112
 113     my (
 114         $sth,
 115         @serverlist,
 116         $server,
 117         $failed,
 118         $servername,
 119     );
 120
 121     my $pidfile='/var/log/koha/processz3950queue.pid';
 122
 123     $error="";
 124
 125     requireDBI($dbh,"addz3950queue");
 126
 127         # list of servers: entry can be a fully qualified URL-type entry
 128         #   or simply just a server ID number.
 129
 130         foreach $server (@z3950list) {
 131             if ($server =~ /:/ ) {
 132                 push @serverlist, $server;
 133             } elsif ($server eq 'DEFAULT' || $server eq 'CHECKED' ) {
 134                 $sth=$dbh->prepare("select host,port,db,userid,password ,name
 135                   from z3950servers
 136                   where checked <> 0 ");
 137                 $sth->execute;
 138                 while ( my ($host, $port, $db, $userid, $password,$servername)
 139                         = $sth->fetchrow ) {
 140                     push @serverlist, "$servername/$host\:$port/$db/$userid/$password";
 141                 } # while
 142             } else {
 143                 $sth=$dbh->prepare("select host,port,db,userid,password
 144                   from z3950servers
 145                   where id=? ");
 146                 $sth->execute($server);
 147                 my ($host, $port, $db, $userid, $password) = $sth->fetchrow;
 148                 push @serverlist, "$server/$host\:$port/$db/$userid/$password";
 149             }
 150         }
 151
 152         my $serverlist='';
 153         foreach (@serverlist) {
 154             $serverlist.="$_ ";
 155         } # foreach
 156         chop $serverlist;
 157
 158         if ( $serverlist !~ /^ +$/ ) {
 159             # Don't allow reinsertion of the same request identifier.
 160             $sth=$dbh->prepare("select identifier from z3950queue
 161                 where identifier=?");
 162             $sth->execute($requestid);
 163             if ( ! $sth->rows) {
 164                 $sth=$dbh->prepare("insert into z3950queue
 165                     (term,type,servers, identifier)
 166                     values (?, ?, ?, ?)");
 167                 $sth->execute($query, $type, $serverlist, $requestid);
 168                 if ( -r $pidfile ) {
 169                     my $pid=`cat $pidfile`;
 170                     chomp $pid;
 171                     my $processcount=kill 1, $pid;
 172                     if ($processcount==0) {
 173                         $error.="Z39.50 search daemon error: no process signalled. ";
 174                     }
 175                 } else {
 176                     $error.="No Z39.50 search daemon running: no file $pidfile. ";
 177                 } # if $pidfile
 178             } else {
 179                 $error.="Duplicate request ID $requestid. ";
 180             } # if rows
 181         } else {
 182             # server list is empty
 183             $error.="No Z39.50 search servers specified. ";
 184         } # if serverlist empty
 185
 186         return $error;
 187
 188 } # sub addz3950queue
 189
 190 #--------------------------------------
 191 # $Log$
 192 # Revision 1.2  2002/07/02 20:31:33  tonnesen
 193 # module added from rel-1-2 branch
 194 #
 195 # Revision 1.1.2.5  2002/06/29 17:33:47  amillar
 196 # Allow DEFAULT as input to addz3950search.
 197 # Check for existence of pid file (cat crashed otherwise).
 198 # Return error messages in addz3950search.
 199 #
 200 # Revision 1.1.2.4  2002/06/28 18:07:27  tonnesen
 201 # marcimport.pl will print an error message if it can not signal the
 202 # processz3950queue program.  The message contains instructions for starting the
 203 # daemon.
 204 #
 205 # Revision 1.1.2.3  2002/06/28 17:45:39  tonnesen
 206 # z3950queue now listens for a -HUP signal before processing the queue.  Z3950.pm
 207 # sends the -HUP signal when queries are added to the queue.
 208 #
 209 # Revision 1.1.2.2  2002/06/26 20:54:31  tonnesen
 210 # use warnings breaks on perl 5.005...
 211 #
 212 # Revision 1.1.2.1  2002/06/26 07:26:41  amillar
 213 # New module for Z39.50 searching
 214 #