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,           # FIXME - Unused argument
  95         $srvid,         # server id number
  96         $default,
  97     )=@_;
  98     # return
  99     my $longname;
 100     #----
 101
 102     $dbh = C4::Context->dbh;
 103
 104         # FIXME - Fix indentation
 105         my $sti=$dbh->prepare("select name
 106                 from z3950servers
 107                 where id=?");
 108         $sti->execute($srvid);
 109         if ( ! $sti->err ) {
 110             ($longname)=$sti->fetchrow;
 111         }
 112         if (! $longname) {
 113             $longname="$default";
 114         }
 115         return $longname;
 116 } # sub z3950servername
 117
 118 #---------------------------------------
 119 sub addz3950queue {
 120     use strict;
 121     # input
 122     my (
 123         $dbh,           # DBI handle
 124                         # FIXME - Unused argument
 125         $query,         # value to look up
 126         $type,          # type of value ("isbn", "lccn", etc).
 127         $requestid,     # Unique value to prevent duplicate searches from multiple HTML form submits
 128         @z3950list,     # list of z3950 servers to query
 129     )=@_;
 130     # Returns:
 131     my $error;
 132
 133     my (
 134         $sth,
 135         @serverlist,
 136         $server,
 137         $failed,
 138         $servername,
 139     );
 140
 141     my $pidfile='/var/log/koha/processz3950queue.pid';
 142
 143     $error="";
 144
 145     $dbh = C4::Context->dbh;
 146
 147         # FIXME - Fix indentation
 148
 149         # list of servers: entry can be a fully qualified URL-type entry
 150         #   or simply just a server ID number.
 151
 152         foreach $server (@z3950list) {
 153             if ($server =~ /:/ ) {
 154                 push @serverlist, $server;
 155             } elsif ($server eq 'DEFAULT' || $server eq 'CHECKED' ) {
 156                 $sth=$dbh->prepare("select host,port,db,userid,password ,name
 157                   from z3950servers
 158                   where checked <> 0 ");
 159                 $sth->execute;
 160                 while ( my ($host, $port, $db, $userid, $password,$servername)
 161                         = $sth->fetchrow ) {
 162                     push @serverlist, "$servername/$host\:$port/$db/$userid/$password";
 163                 } # while
 164             } else {
 165                 $sth=$dbh->prepare("select host,port,db,userid,password
 166                   from z3950servers
 167                   where id=? ");
 168                 $sth->execute($server);
 169                 my ($host, $port, $db, $userid, $password) = $sth->fetchrow;
 170                 push @serverlist, "$server/$host\:$port/$db/$userid/$password";
 171             }
 172         }
 173
 174         my $serverlist='';
 175         foreach (@serverlist) {
 176             $serverlist.="$_ ";
 177         } # foreach
 178         chop $serverlist;
 179
 180         if ( $serverlist !~ /^ +$/ ) {
 181             # Don't allow reinsertion of the same request identifier.
 182             $sth=$dbh->prepare("select identifier from z3950queue
 183                 where identifier=?");
 184             $sth->execute($requestid);
 185             if ( ! $sth->rows) {
 186                 $sth=$dbh->prepare("insert into z3950queue
 187                     (term,type,servers, identifier)
 188                     values (?, ?, ?, ?)");
 189                 $sth->execute($query, $type, $serverlist, $requestid);
 190                 if ( -r $pidfile ) {
 191                     my $pid=`cat $pidfile`;
 192                     chomp $pid;
 193                     my $processcount=kill 1, $pid;
 194                     if ($processcount==0) {
 195                         $error.="Z39.50 search daemon error: no process signalled. ";
 196                     }
 197                 } else {
 198                     $error.="No Z39.50 search daemon running: no file $pidfile. ";
 199                 } # if $pidfile
 200             } else {
 201                 $error.="Duplicate request ID $requestid. ";
 202             } # if rows
 203         } else {
 204             # server list is empty
 205             $error.="No Z39.50 search servers specified. ";
 206         } # if serverlist empty
 207
 208         return $error;
 209
 210 } # sub addz3950queue
 211
 212 #--------------------------------------
 213 # $Log$
 214 # Revision 1.4  2002/10/11 12:35:35  arensb
 215 # Replaced &requireDBI with C4::Context->dbh
 216 #
 217 # Revision 1.3  2002/08/14 18:12:52  tonnesen
 218 # Added copyright statement to all .pl and .pm files
 219 #
 220 # Revision 1.2  2002/07/02 20:31:33  tonnesen
 221 # module added from rel-1-2 branch
 222 #
 223 # Revision 1.1.2.5  2002/06/29 17:33:47  amillar
 224 # Allow DEFAULT as input to addz3950search.
 225 # Check for existence of pid file (cat crashed otherwise).
 226 # Return error messages in addz3950search.
 227 #
 228 # Revision 1.1.2.4  2002/06/28 18:07:27  tonnesen
 229 # marcimport.pl will print an error message if it can not signal the
 230 # processz3950queue program.  The message contains instructions for starting the
 231 # daemon.
 232 #
 233 # Revision 1.1.2.3  2002/06/28 17:45:39  tonnesen
 234 # z3950queue now listens for a -HUP signal before processing the queue.  Z3950.pm
 235 # sends the -HUP signal when queries are added to the queue.
 236 #
 237 # Revision 1.1.2.2  2002/06/26 20:54:31  tonnesen
 238 # use warnings breaks on perl 5.005...
 239 #
 240 # Revision 1.1.2.1  2002/06/26 07:26:41  amillar
 241 # New module for Z39.50 searching
 242 #