X-Git-Url: http://git.rot13.org/?a=blobdiff_plain;f=server.pl;h=7b02608146806bcdba29ec85a47bdb48871328a3;hb=a0d3a60cd95afff5241f8e2d3a2955ecdffd1395;hp=3d5850eaea89b4417519272a4f43809109262411;hpb=942b2c7aff7ea513a1fd4640abd72ccb5e9380ba;p=Biblio-Z3950.git

diff --git a/server.pl b/server.pl
index 3d5850e..7b02608 100755
--- a/server.pl
+++ b/server.pl
@@ -5,9 +5,35 @@ use strict;
 
 use Net::Z3950::SimpleServer;
 use Net::Z3950::OID;
-use COBISS;
-
-my $max_records = 3; # XXX configure this
+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 {
@@ -15,118 +41,158 @@ sub diag {
 }
 
 sub InitHandle {
-    my $this    = shift;
+    my $self    = shift;
     my $session = {};
 
-    $this->{HANDLE}   = $session;
-    $this->{IMP_NAME} = "Z39.50 HTML scraping bot";
-    $this->{IMP_VER}  = "0.1";
+    $self->{HANDLE}   = $session;
+    $self->{IMP_NAME} = "Biblio Z39.50";
+    $self->{IMP_VER}  = "0.2";
     $session->{SETS}  = {};
 }
 
-use Data::Dumper;
-
 sub SearchHandle {
-    my $this    = shift;
+    my $self    = shift;
 
-diag "SearchHandle ",Dumper($this);
+diag "SearchHandle ",Dumper($self);
 
-    my $session = $this->{HANDLE};
-    my $rpn     = $this->{RPN};
+    my $session = $self->{HANDLE};
+    my $rpn     = $self->{RPN};
     my $query;
 
-    eval { $query = $rpn->{query}->render(); };
+	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?
-        $this->{ERR_CODE} = $@->{errcode};
-        $this->{ERR_STR}  = $@->{errstr};
+        $self->{ERR_CODE} = $@->{errcode};
+        $self->{ERR_STR}  = $@->{errstr};
         return;
     }
 
+	$query = decode('utf-8', $query); # FIXME Zoom encoding
+
 diag "search for $query";
 
-    my $setname  = $this->{SETNAME};
-    my $repl_set = $this->{REPL_SET};
+    my $setname  = $self->{SETNAME};
+    my $repl_set = $self->{REPL_SET};
 diag "SETNAME $setname REPL_SET $repl_set";
-    my $result;
-    unless ( $result = COBISS->search( $query ) ) {
-        $this->{ERR_CODE} = 108;
+    my $hits;
+    unless ( $hits = $from->search( $query ) ) {
+		warn $self->{ERR_STR} = "no results for $query";
+        $self->{ERR_CODE} = 108;
         return;
     }
-    my $hits = $COBISS::hits || diag "no results for $query";
 diag "got $hits hits";
     my $rs   = {
         lower => 1,
         upper => $hits < $max_records ? $max_records : $hits,
-        data  => $result->{'resultElements'},	# FIXME
+        hits  => $hits,
+		from => $from,
+		results => [ undef ], # we don't use 0 element
+		database => $database,
     };
     my $sets = $session->{SETS};
 
     if ( defined( $sets->{$setname} ) && !$repl_set ) {
-        $this->{ERR_CODE} = 21;
+        $self->{ERR_CODE} = 21;
         return;
     }
     if ( scalar keys %$sets >= $max_result_sets ) {
-        $this->{ERR_CODE} = 112;
-        $this->{ERR_STR}  = "Max number is $max_result_sets";
+        $self->{ERR_CODE} = 112;
+        $self->{ERR_STR}  = "Max number is $max_result_sets";
         return;
     }
     $sets->{$setname} = $rs;
-    $this->{HITS} = $session->{HITS} = $hits;
+    $self->{HITS} = $session->{HITS} = $hits;
     $session->{QUERY} = $query;
 }
 
 sub FetchHandle {
-    my $this     = shift;
-    my $session  = $this->{HANDLE};
-    my $setname  = $this->{SETNAME};
-    my $req_form = $this->{REQ_FORM};
-    my $offset   = $this->{OFFSET};
+    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;
 
-diag Dumper( $this );
-
     if ( !defined( $rs = $sets->{$setname} ) ) {
-        $this->{ERR_CODE} = 30;
+        $self->{ERR_CODE} = 30;
         return;
     }
     if ( $offset > $hits ) {
-        $this->{ERR_CODE} = 13;
+        $self->{ERR_CODE} = 13;
         return;
     }
-    $this->{BASENAME} = "HtmlZ3950";
 
-#    if ( !defined($req_form) || ( $req_form eq &Net::Z3950::OID::xml ) )
-    if (0)
-    {    ## XML records
-        $this->{REP_FORM} = &Net::Z3950::OID::xml;
-        $this->{RECORD}   = '<xml>FIXME: not implementd</xml>';
-    }
-    elsif ( $req_form eq &Net::Z3950::OID::unimarc ) {	# FIXME convert to usmarc
-        $this->{REP_FORM} = &Net::Z3950::OID::unimarc;
-        $this->{RECORD} = COBISS->fetch_rec('unimarc');
-    }
-    elsif ( $req_form eq &Net::Z3950::OID::usmarc ) {	# FIXME convert to usmarc
-        $this->{REP_FORM} = &Net::Z3950::OID::usmarc;
-        $this->{RECORD} = COBISS->fetch_rec('usmarc');
-    }
-    else {    ## Unsupported record format
-        $this->{ERR_CODE} = 239;
-        $this->{ERR_STR}  = $req_form;
+    $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 ) {
-        $this->{LAST} = 1;
+        $self->{LAST} = 1;
     }
     else {
-        $this->{LAST} = 0;
+        $self->{LAST} = 0;
     }
 }
 
 sub CloseHandle {
-    my $this = shift;
+    my $self = shift;
 }
 
 my $z = new Net::Z3950::SimpleServer(
@@ -140,42 +206,45 @@ $z->launch_server( $0, @ARGV );
 package Net::Z3950::RPN::And;
 
 sub render {
-    my $this = shift;
-    return $this->[0]->render() . ' AND ' . $this->[1]->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 $this = shift;
-    return $this->[0]->render() . ' OR ' . $this->[1]->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 $this = shift;
-    return $this->[0]->render() . ' AND NOT ' . $this->[1]->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);
-use COBISS;
 
 sub render {
-    my $this       = shift;
-
-print "render ", dump($this);
+	my ($self,$usemap) = @_;
 
-my $from = 'COBISS';
+	die "no usemap" unless $usemap;
 
-my $usemap = eval "${from}::usemap;";
-warn "# $from usermap ",dump($usemap);
+warn "# render ", dump($self);
+warn "# usemap ", dump($usemap);
 
     my $attributes = {};
     my $prefix     = "";
-    foreach my $attr ( @{ $this->{attributes} } ) {
+    foreach my $attr ( @{ $self->{attributes} } ) {
         my $type  = $attr->{attributeType};
         my $value = $attr->{attributeValue};
         $attributes->{$type} = $value;
@@ -185,6 +254,7 @@ warn "# $from usermap ",dump($usemap);
             $prefix = $field;
         }
         else {
+			warn "FIXME add $use in usemap  ",dump( $usemap );
             die { errcode => 114, errstr => $use }; ## Unsupported use attribute
         }
     }
@@ -206,19 +276,24 @@ warn "# $from usermap ",dump($usemap);
         }
     }
     if ( defined( $attributes->{5} ) ) {                ## No truncation
-        die { errcode => 113, errstr => 5 };
+#	die { errcode => 113, errstr => 5 };
+	warn "# truncation is ignored";
     }
     my $comp = $attributes->{6};
     if ($prefix) {
         if ( defined($comp) && ( $comp >= 2 ) ) {
-            $prefix = "all$prefix= ";
-        }
-        else {
-            $prefix = "$prefix=";
+            $prefix = "all$prefix"; # FIXME?
         }
     }
 
-    my $q = $prefix . $this->{term};
+	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;
 }