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