server.pl

   1 #!/usr/bin/perl
   2
   3 use warnings;
   4 use strict;
   5
   6 use Net::Z3950::SimpleServer;
   7 use Net::Z3950::OID;
   8 use Data::Dumper;
   9 #use COBISS;
  10 use Aleph;
  11 use GoogleBooks;
  12 use vuFind;
  13 use DPLA;
  14
  15 use Encode;
  16
  17 # databases names (left) must be in uppercase!
  18 my $databases = {
  19 #       'COBISS' => 'COBISS',
  20         'NSK01'  => 'Aleph',
  21         'NSK10'  => 'Aleph',
  22         'ZAG01'  => 'Aleph',
  23         'GOOGLEBOOKS' => 'GoogleBooks',
  24         'HATHITRUST' => 'vuFind',
  25         'DPLA'   => 'DPLA',
  26 };
  27
  28 my $max_records = 3; # XXX configure this
  29 my $max_result_sets = 10;
  30
  31 sub diag {
  32         print "# ", @_, $/;
  33 }
  34
  35 sub InitHandle {
  36     my $self    = shift;
  37     my $session = {};
  38
  39     $self->{HANDLE}   = $session;
  40     $self->{IMP_NAME} = "Biblio Z39.50";
  41     $self->{IMP_VER}  = "0.2";
  42     $session->{SETS}  = {};
  43 }
  44
  45 sub SearchHandle {
  46     my $self    = shift;
  47
  48 diag "SearchHandle ",Dumper($self);
  49
  50     my $session = $self->{HANDLE};
  51     my $rpn     = $self->{RPN};
  52     my $query;
  53
  54         my $database = uc $self->{DATABASES}->[0];
  55         my $module = $databases->{$database};
  56         if ( ! defined $module ) {
  57         $self->{ERR_CODE} = 108;
  58                 warn $self->{ERR_STR} = "$database NOT FOUND in available databases: " . join(" ", keys %$databases);
  59                 return;
  60         }
  61
  62         my $from = $module->new( $database );
  63
  64 diag "using $module for $database ", Dumper( $from );
  65
  66         eval { $query = $rpn->{query}->render( $from->usemap ); };
  67         warn "ERROR: $@" if $@;
  68     if ( $@ && ref($@) ) {    ## Did someone/something report any errors?
  69         $self->{ERR_CODE} = $@->{errcode};
  70         $self->{ERR_STR}  = $@->{errstr};
  71         return;
  72     }
  73
  74         $query = decode('utf-8', $query); # FIXME Zoom encoding
  75
  76 diag "search for $query";
  77
  78     my $setname  = $self->{SETNAME};
  79     my $repl_set = $self->{REPL_SET};
  80 diag "SETNAME $setname REPL_SET $repl_set";
  81     my $hits;
  82     unless ( $hits = $from->search( $query ) ) {
  83                 warn $self->{ERR_STR} = "no results for $query";
  84         $self->{ERR_CODE} = 108;
  85         return;
  86     }
  87 diag "got $hits hits";
  88     my $rs   = {
  89         lower => 1,
  90         upper => $hits < $max_records ? $max_records : $hits,
  91         hits  => $hits,
  92                 from => $from,
  93                 results => [ undef ], # we don't use 0 element
  94                 database => $database,
  95     };
  96     my $sets = $session->{SETS};
  97
  98     if ( defined( $sets->{$setname} ) && !$repl_set ) {
  99         $self->{ERR_CODE} = 21;
 100         return;
 101     }
 102     if ( scalar keys %$sets >= $max_result_sets ) {
 103         $self->{ERR_CODE} = 112;
 104         $self->{ERR_STR}  = "Max number is $max_result_sets";
 105         return;
 106     }
 107     $sets->{$setname} = $rs;
 108     $self->{HITS} = $session->{HITS} = $hits;
 109     $session->{QUERY} = $query;
 110 }
 111
 112 sub FetchHandle {
 113     my $self     = shift;
 114     my $session  = $self->{HANDLE};
 115     my $setname  = $self->{SETNAME};
 116     my $req_form = $self->{REQ_FORM};
 117     my $offset   = $self->{OFFSET};
 118     my $sets     = $session->{SETS};
 119     my $hits     = $session->{HITS};
 120     my $rs;
 121     my $record;
 122
 123     if ( !defined( $rs = $sets->{$setname} ) ) {
 124         $self->{ERR_CODE} = 30;
 125         return;
 126     }
 127     if ( $offset > $hits ) {
 128         $self->{ERR_CODE} = 13;
 129         return;
 130     }
 131
 132     $self->{BASENAME} = $rs->{database};
 133
 134         my $format =
 135                 $req_form eq Net::Z3950::OID::xml()     ? 'xml' :
 136                 $req_form eq Net::Z3950::OID::unimarc() ? 'unimarc' :
 137                 $req_form eq Net::Z3950::OID::usmarc()  ? 'marc' : # XXX usmarc -> marc
 138                 die "unknown format $req_form";
 139
 140         if ( ! $format ) {
 141                 warn "ERROR: $req_form format not supported";
 142         $self->{ERR_CODE} = 239; ## Unsupported record format
 143         $self->{ERR_STR}  = $req_form;
 144         return;
 145         }
 146
 147         $self->{REP_FORM} = $req_form;
 148
 149         my $from = $rs->{from} || die "no from?";
 150         # fetch records up to offset
 151         while(  $#{ $rs->{results} } < $offset ) {
 152                 my $marc = $from->next_marc;
 153                 last if ! $marc; # abort results
 154                 push @{ $rs->{results} }, $marc;
 155                 warn "# rs result ", $#{ $rs->{results} },"\n";
 156         }
 157
 158         my $id = $rs->{results}->[$offset] || die "no id for record $offset in ",Dumper( $rs->{results} );
 159
 160         my $path = 'marc/' . $rs->{database} . "/$id.$format";
 161         if ( ! -e $path ) {
 162                 warn "ERROR: $path not found";
 163                 ## Unsupported record format
 164         $self->{ERR_CODE} = 239;
 165         $self->{ERR_STR}  = $req_form;
 166         return;
 167     }
 168
 169         {
 170                 open(my $in, '<', $path) || die "$path: $!";
 171                 local $/ = undef;
 172                 my $marc = <$in>;
 173                 close($in);
 174                 $self->{RECORD} = $marc;
 175         }
 176
 177
 178     if ( $offset == $hits ) {
 179         $self->{LAST} = 1;
 180     }
 181     else {
 182         $self->{LAST} = 0;
 183     }
 184 }
 185
 186 sub CloseHandle {
 187     my $self = shift;
 188 }
 189
 190 my $z = new Net::Z3950::SimpleServer(
 191     INIT   => \&InitHandle,
 192     SEARCH => \&SearchHandle,
 193     FETCH  => \&FetchHandle,
 194     CLOSE  => \&CloseHandle
 195 );
 196 $z->launch_server( $0, @ARGV );
 197
 198 package Net::Z3950::RPN::And;
 199
 200 sub render {
 201         my ($self,$usemap) = @_;
 202     return $self->[0]->render($usemap)
 203                 . ( $usemap->{RPN}->{And} || ' AND ' )
 204                 . $self->[1]->render($usemap);
 205 }
 206
 207 package Net::Z3950::RPN::Or;
 208
 209 sub render {
 210         my ($self,$usemap) = @_;
 211     return $self->[0]->render($usemap)
 212                 . ( $usemap->{RPN}->{Or} || ' OR ' )
 213                 . $self->[1]->render($usemap);
 214 }
 215
 216 package Net::Z3950::RPN::AndNot;
 217
 218 sub render {
 219         my ($self,$usemap) = @_;
 220     return $self->[0]->render($usemap)
 221                 . ( $usemap->{RPN}->{Or} || ' AND NOT ' )
 222                 . $self->[1]->render($usemap);
 223 }
 224
 225 package Net::Z3950::RPN::Term;
 226
 227 use Data::Dump qw(dump);
 228
 229 sub render {
 230         my ($self,$usemap) = @_;
 231
 232         die "no usemap" unless $usemap;
 233
 234 warn "# render ", dump($self);
 235 warn "# usemap ", dump($usemap);
 236
 237     my $attributes = {};
 238     my $prefix     = "";
 239     foreach my $attr ( @{ $self->{attributes} } ) {
 240         my $type  = $attr->{attributeType};
 241         my $value = $attr->{attributeValue};
 242         $attributes->{$type} = $value;
 243     }
 244     if ( defined( my $use = $attributes->{1} ) ) {
 245         if ( defined( my $field = $usemap->{$use} ) ) {
 246             $prefix = $field;
 247         }
 248         else {
 249                         warn "FIXME add $use in usemap  ",dump( $usemap );
 250             die { errcode => 114, errstr => $use }; ## Unsupported use attribute
 251         }
 252     }
 253     if ( defined( my $rel = $attributes->{2} ) )
 254     {    ## No relation attributes supported
 255         if ( $rel != 3 ) {
 256             die { errcode => 117, errstr => $rel };
 257         }
 258     }
 259     if ( defined( my $pos = $attributes->{3} ) )
 260     {    ## No position attributes either
 261         if ( $pos != 3 ) {
 262             die { errcode => 119, errstr => $pos };
 263         }
 264     }
 265     if ( defined( my $struc = $attributes->{4} ) ) {    ## No structure
 266         if ( ( $struc != 1 ) && ( $struc != 2 ) ) {
 267             die { errcode => 118, errstr => $struc };
 268         }
 269     }
 270     if ( defined( $attributes->{5} ) ) {                ## No truncation
 271         die { errcode => 113, errstr => 5 };
 272     }
 273     my $comp = $attributes->{6};
 274     if ($prefix) {
 275         if ( defined($comp) && ( $comp >= 2 ) ) {
 276             $prefix = "all$prefix"; # FIXME?
 277         }
 278     }
 279
 280         my $q;
 281
 282         if ( $usemap->{prefix_term} ) {
 283                 warn "# using custom prefix_term query";
 284                 $q = $usemap->{prefix_term}->( $prefix, $self->{term} );
 285         } else {
 286         $q = $prefix . $self->{term} . '*';
 287         }
 288         print "# q: $q\n";
 289         return $q;
 290 }
 291