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