X-Git-Url: http://git.rot13.org/?a=blobdiff_plain;f=server.pl;h=8f0d7faf1b4a9062dda0120bfacaedf49b217649;hb=9c5761f797b5a9f3432381412b13a78c131cd0a9;hp=1e17f2c02b601925540e00b4a1bd9db1c19db43a;hpb=c408b0af82886f884c9a17698695bd0f9e738a58;p=Biblio-Z3950.git diff --git a/server.pl b/server.pl index 1e17f2c..8f0d7fa 100755 --- a/server.pl +++ b/server.pl @@ -1,9 +1,21 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl + +use warnings; +use strict; use Net::Z3950::SimpleServer; use Net::Z3950::OID; +use Data::Dumper; use COBISS; -use strict; +use Aleph; +use Encode; + +my $databases = { +# 'COBISS' => 'COBISS', + 'NSK01' => 'Aleph', + 'NSK10' => 'Aleph', + 'ZAG01' => 'Aleph', +}; my $max_records = 3; # XXX configure this my $max_result_sets = 10; @@ -13,117 +25,156 @@ 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: $@" 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 $result; - unless ( $result = COBISS->search( $query ) ) { - $this->{ERR_CODE} = 108; + 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; } - 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} = 'FIXME: not implementd'; - } - 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 ) { + push @{ $rs->{results} }, $from->next_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( @@ -137,45 +188,50 @@ $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) . ' 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) . ' 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) . ' AND NOT ' . $self->[1]->render($usemap); } package Net::Z3950::RPN::Term; +use Data::Dump qw(dump); use COBISS; sub render { - my $this = shift; + my ($self,$usemap) = @_; + + die "no usemap" unless $usemap; -print "render ", $this; +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; } if ( defined( my $use = $attributes->{1} ) ) { - if ( defined( my $field = COBISS::usemap($use) ) ) { + 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 } } @@ -209,7 +265,7 @@ print "render ", $this; } } - my $q = $prefix . $this->{term}; + my $q = $prefix . $self->{term} . '*'; print "# q: $q\n"; return $q; }