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