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