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