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