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