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