Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
executable file 301 lines (252 sloc) 7.09 KB
#!/usr/bin/perl
use warnings;
use strict;
use Net::Z3950::SimpleServer;
use Net::Z3950::OID;
use Data::Dumper;
#use COBISS;
use Aleph;
use GoogleBooks;
use vuFind;
use DPLA;
use AlephTR;
use CROSBI;
use Encode;
# databases names (left) must be in uppercase!
my $databases = {
# 'COBISS' => 'COBISS',
'NSK01' => 'Aleph',
'NSK10' => 'Aleph',
'ZAG01' => 'Aleph',
'GOOGLEBOOKS' => 'GoogleBooks',
'HATHITRUST' => 'vuFind',
'DPLA' => 'DPLA',
'MKUTUP' => 'AlephTR',
'CROSBI' => 'CROSBI',
'CROSBI-CASOPIS' => 'CROSBI',
'CROSBI-PREPRINT' => 'CROSBI',
'CROSBI-RKNJIGA' => 'CROSBI',
'CROSBI-ZBORNIK' => 'CROSBI',
};
my $max_records = 10; # XXX configure this
my $max_result_sets = 10;
sub diag {
print "# ", @_, $/;
}
sub InitHandle {
my $self = shift;
my $session = {};
$self->{HANDLE} = $session;
$self->{IMP_NAME} = "Biblio Z39.50";
$self->{IMP_VER} = "0.2";
$session->{SETS} = {};
}
sub SearchHandle {
my $self = shift;
diag "SearchHandle ",Dumper($self);
my $session = $self->{HANDLE};
my $rpn = $self->{RPN};
my $query;
my $database = uc $self->{DATABASES}->[0];
my $module = $databases->{$database};
if ( ! defined $module ) {
$self->{ERR_CODE} = 108;
warn $self->{ERR_STR} = "$database NOT FOUND in available databases: " . join(" ", keys %$databases);
return;
}
my $from = $module->new( $database );
diag "using $module for $database ", Dumper( $from );
eval { $query = $rpn->{query}->render( $from->usemap ); };
warn "ERROR: ", Dumper($@) if $@;
if ( $@ && ref($@) ) { ## Did someone/something report any errors?
$self->{ERR_CODE} = $@->{errcode};
$self->{ERR_STR} = $@->{errstr};
return;
}
$query = decode('utf-8', $query); # FIXME Zoom encoding
diag "search for $query";
my $setname = $self->{SETNAME};
my $repl_set = $self->{REPL_SET};
diag "SETNAME $setname REPL_SET $repl_set";
my $hits;
unless ( $hits = $from->search( $query ) ) {
warn $self->{ERR_STR} = "no results for $query";
$self->{ERR_CODE} = 108;
return;
}
diag "got $hits hits";
my $rs = {
lower => 1,
upper => $hits < $max_records ? $max_records : $hits,
hits => $hits,
from => $from,
results => [ undef ], # we don't use 0 element
database => $database,
};
my $sets = $session->{SETS};
if ( defined( $sets->{$setname} ) && !$repl_set ) {
$self->{ERR_CODE} = 21;
return;
}
if ( scalar keys %$sets >= $max_result_sets ) {
$self->{ERR_CODE} = 112;
$self->{ERR_STR} = "Max number is $max_result_sets";
return;
}
$sets->{$setname} = $rs;
$self->{HITS} = $session->{HITS} = $hits;
$session->{QUERY} = $query;
}
sub FetchHandle {
my $self = shift;
my $session = $self->{HANDLE};
my $setname = $self->{SETNAME};
my $req_form = $self->{REQ_FORM};
my $offset = $self->{OFFSET};
my $sets = $session->{SETS};
my $hits = $session->{HITS};
my $rs;
my $record;
if ( !defined( $rs = $sets->{$setname} ) ) {
$self->{ERR_CODE} = 30;
return;
}
if ( $offset > $hits ) {
$self->{ERR_CODE} = 13;
return;
}
$self->{BASENAME} = $rs->{database};
my $format =
$req_form eq Net::Z3950::OID::xml() ? 'xml' :
$req_form eq Net::Z3950::OID::unimarc() ? 'unimarc' :
$req_form eq Net::Z3950::OID::usmarc() ? 'marc' : # XXX usmarc -> marc
die "unknown format $req_form";
if ( ! $format ) {
warn "ERROR: $req_form format not supported";
$self->{ERR_CODE} = 239; ## Unsupported record format
$self->{ERR_STR} = $req_form;
return;
}
$self->{REP_FORM} = $req_form;
my $from = $rs->{from} || die "no from?";
# fetch records up to offset
while( $#{ $rs->{results} } < $offset ) {
my $marc = $from->next_marc;
last if ! $marc; # abort results
push @{ $rs->{results} }, $marc;
warn "# rs result ", $#{ $rs->{results} },"\n";
}
my $id = $rs->{results}->[$offset] || die "no id for record $offset in ",Dumper( $rs->{results} );
my $path = 'marc/' . $rs->{database} . "/$id.$format";
if ( ! -e $path ) {
warn "ERROR: $path not found";
## Unsupported record format
$self->{ERR_CODE} = 239;
$self->{ERR_STR} = $req_form;
return;
}
{
open(my $in, '<', $path) || die "$path: $!";
local $/ = undef;
my $marc = <$in>;
close($in);
$self->{RECORD} = $marc;
}
if ( $offset == $hits ) {
$self->{LAST} = 1;
}
else {
$self->{LAST} = 0;
}
}
sub CloseHandle {
my $self = shift;
}
my $z = new Net::Z3950::SimpleServer(
INIT => \&InitHandle,
SEARCH => \&SearchHandle,
FETCH => \&FetchHandle,
CLOSE => \&CloseHandle
);
$z->launch_server( $0, @ARGV );
package Net::Z3950::RPN::And;
sub render {
my ($self,$usemap) = @_;
return $self->[0]->render($usemap)
. ( $usemap->{RPN}->{And} || ' AND ' )
. $self->[1]->render($usemap);
}
package Net::Z3950::RPN::Or;
sub render {
my ($self,$usemap) = @_;
return $self->[0]->render($usemap)
. ( $usemap->{RPN}->{Or} || ' OR ' )
. $self->[1]->render($usemap);
}
package Net::Z3950::RPN::AndNot;
sub render {
my ($self,$usemap) = @_;
return $self->[0]->render($usemap)
. ( $usemap->{RPN}->{Or} || ' AND NOT ' )
. $self->[1]->render($usemap);
}
package Net::Z3950::RPN::Term;
use Data::Dump qw(dump);
sub render {
my ($self,$usemap) = @_;
die "no usemap" unless $usemap;
warn "# render ", dump($self);
warn "# usemap ", dump($usemap);
my $attributes = {};
my $prefix = "";
foreach my $attr ( @{ $self->{attributes} } ) {
my $type = $attr->{attributeType};
my $value = $attr->{attributeValue};
$attributes->{$type} = $value;
}
if ( defined( my $use = $attributes->{1} ) ) {
if ( defined( my $field = $usemap->{$use} ) ) {
$prefix = $field;
}
else {
warn "FIXME add $use in usemap ",dump( $usemap );
die { errcode => 114, errstr => $use }; ## Unsupported use attribute
}
}
if ( defined( my $rel = $attributes->{2} ) )
{ ## No relation attributes supported
if ( $rel != 3 ) {
die { errcode => 117, errstr => $rel };
}
}
if ( defined( my $pos = $attributes->{3} ) )
{ ## No position attributes either
if ( $pos != 3 ) {
die { errcode => 119, errstr => $pos };
}
}
if ( defined( my $struc = $attributes->{4} ) ) { ## No structure
if ( ( $struc != 1 ) && ( $struc != 2 ) ) {
die { errcode => 118, errstr => $struc };
}
}
if ( defined( $attributes->{5} ) ) { ## No truncation
# die { errcode => 113, errstr => 5 };
warn "# truncation is ignored";
}
my $comp = $attributes->{6};
if ($prefix) {
if ( defined($comp) && ( $comp >= 2 ) ) {
$prefix = "all$prefix"; # FIXME?
}
}
my $q;
if ( $usemap->{prefix_term} ) {
warn "# using custom prefix_term query";
$q = $usemap->{prefix_term}->( $prefix, $self->{term} );
} else {
$q = $prefix . $self->{term} . '*';
}
print "# q: $q\n";
return $q;
}