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