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