Koha/C4/Z3950.pm

#!/usr/bin/perl

# $Id$

package C4::Z3950; 

# Routines for handling Z39.50 lookups

# Koha library project  www.koha.org

# Licensed under the GPL

use strict;

# standard or CPAN modules used
use DBI;

# Koha modules used
use C4::Database;
use C4::Input;
use C4::Biblio;

#------------------

require Exporter;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

# set the version for version checking
$VERSION = 0.01;

@ISA = qw(Exporter);
@EXPORT = qw(
	 &z3950servername 
	 &addz3950queue 
);
%EXPORT_TAGS = ( );     # eg: TAG => [ qw!name1 name2! ],

# your exported package globals go here,
# as well as any optionally exported functions

@EXPORT_OK   = qw($Var1 %Hashit);

# non-exported package globals go here
use vars qw(@more $stuff);

# initalize package globals, first exported ones

my $Var1   = '';
my %Hashit = ();

# then the others (which are still accessible as $Some::Module::stuff)
my $stuff  = '';
my @more   = ();

# all file-scoped lexicals must be created before
# the functions below that use them.

# file-private lexicals go here
my $priv_var    = '';
my %secret_hash = ();

# here's a file-private function as a closure,
# callable as &$priv_func;  it cannot be prototyped.
my $priv_func = sub {
  # stuff goes here.
  };
  
# make all your functions, whether exported or not;
#------------------------------------------------


sub z3950servername {
    # inputs
    my (
	$dbh,
	$srvid,		# server id number 
	$default,
    )=@_;
    # return
    my $longname;
    #----

    requireDBI($dbh,"z3950servername");

	my $sti=$dbh->prepare("select name 
		from z3950servers 
		where id=?");
	$sti->execute($srvid);
	if ( ! $sti->err ) {
	    ($longname)=$sti->fetchrow;
	}
	if (! $longname) {
	    $longname="$default";
	}
	return $longname;
} # sub z3950servername

#---------------------------------------
sub addz3950queue {
    use strict;
    # input
    my (
	$dbh,		# DBI handle
	$query,		# value to look up
	$type,		# type of value ("isbn", "lccn", etc).
	$requestid,	# Unique value to prevent duplicate searches from multiple HTML form submits
	@z3950list,	# list of z3950 servers to query
    )=@_;
    # Returns:
    my $error;

    my (
	$sth,
	@serverlist,
	$server,
	$failed,
	$servername,
    );

    my $pidfile='/var/log/koha/processz3950queue.pid';
    
    $error="";

    requireDBI($dbh,"addz3950queue");

	# list of servers: entry can be a fully qualified URL-type entry
        #   or simply just a server ID number.

        foreach $server (@z3950list) {
	    if ($server =~ /:/ ) {
		push @serverlist, $server;
	    } elsif ($server eq 'DEFAULT' || $server eq 'CHECKED' ) {
                $sth=$dbh->prepare("select host,port,db,userid,password ,name
	          from z3950servers 
	          where checked <> 0 ");
		$sth->execute;
		while ( my ($host, $port, $db, $userid, $password,$servername) 
			= $sth->fetchrow ) {
		    push @serverlist, "$servername/$host\:$port/$db/$userid/$password";
		} # while
	    } else {
                $sth=$dbh->prepare("select host,port,db,userid,password
	          from z3950servers 
	          where id=? ");
		$sth->execute($server);
		my ($host, $port, $db, $userid, $password) = $sth->fetchrow;
		push @serverlist, "$server/$host\:$port/$db/$userid/$password";
	    }
	}

	my $serverlist='';
	foreach (@serverlist) {
	    $serverlist.="$_ ";
    	} # foreach
	chop $serverlist;

	if ( $serverlist !~ /^ +$/ ) {
	    # Don't allow reinsertion of the same request identifier.
	    $sth=$dbh->prepare("select identifier from z3950queue 
		where identifier=?");
	    $sth->execute($requestid);
	    if ( ! $sth->rows) {
	        $sth=$dbh->prepare("insert into z3950queue 
		    (term,type,servers, identifier) 
		    values (?, ?, ?, ?)");
	        $sth->execute($query, $type, $serverlist, $requestid);
		if ( -r $pidfile ) { 
	            my $pid=`cat $pidfile`;
	            chomp $pid;
	            my $processcount=kill 1, $pid;
	            if ($processcount==0) {
		        $error.="Z39.50 search daemon error: no process signalled. ";
	            }
		} else {
		    $error.="No Z39.50 search daemon running: no file $pidfile. ";
		} # if $pidfile
	    } else {
	        $error.="Duplicate request ID $requestid. ";
	    } # if rows
	} else {
	    # server list is empty
	    $error.="No Z39.50 search servers specified. ";
	} # if serverlist empty
	
	return $error;

} # sub addz3950queue

#--------------------------------------
# $Log$
# Revision 1.2  2002/07/02 20:31:33  tonnesen
# module added from rel-1-2 branch
#
# Revision 1.1.2.5  2002/06/29 17:33:47  amillar
# Allow DEFAULT as input to addz3950search.
# Check for existence of pid file (cat crashed otherwise).
# Return error messages in addz3950search.
#
# Revision 1.1.2.4  2002/06/28 18:07:27  tonnesen
# marcimport.pl will print an error message if it can not signal the
# processz3950queue program.  The message contains instructions for starting the
# daemon.
#
# Revision 1.1.2.3  2002/06/28 17:45:39  tonnesen
# z3950queue now listens for a -HUP signal before processing the queue.  Z3950.pm
# sends the -HUP signal when queries are added to the queue.
#
# Revision 1.1.2.2  2002/06/26 20:54:31  tonnesen
# use warnings breaks on perl 5.005...
#
# Revision 1.1.2.1  2002/06/26 07:26:41  amillar
# New module for Z39.50 searching
#