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 $this    = shift;
  28     my $session = {};
  29
  30     $this->{HANDLE}   = $session;
  31     $this->{IMP_NAME} = "Biblio Z39.50";
  32     $this->{IMP_VER}  = "0.2";
  33     $session->{SETS}  = {};
  34 }
  35
  36 sub SearchHandle {
  37     my $this    = shift;
  38
  39 diag "SearchHandle ",Dumper($this);
  40
  41     my $session = $this->{HANDLE};
  42     my $rpn     = $this->{RPN};
  43     my $query;
  44
  45         my $database = uc $this->{DATABASES}->[0];
  46         my $module = $databases->{$database};
  47         if ( ! defined $module ) {
  48         $this->{ERR_CODE} = 108;
  49                 warn $this->{ERR_STR} = "unknown database $database - available: " . 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         $this->{ERR_CODE} = $@->{errcode};
  61         $this->{ERR_STR}  = $@->{errstr};
  62         return;
  63     }
  64
  65 diag "search for $query";
  66
  67     my $setname  = $this->{SETNAME};
  68     my $repl_set = $this->{REPL_SET};
  69 diag "SETNAME $setname REPL_SET $repl_set";
  70     my $hits;
  71     unless ( $hits = $from->search( $query ) ) {
  72         $this->{ERR_CODE} = 108;
  73         return;
  74     }
  75 diag "got $hits hits";
  76     my $rs   = {
  77         lower => 1,
  78         upper => $hits < $max_records ? $max_records : $hits,
  79         hits  => $hits,
  80                 from => $from,
  81     };
  82     my $sets = $session->{SETS};
  83
  84     if ( defined( $sets->{$setname} ) && !$repl_set ) {
  85         $this->{ERR_CODE} = 21;
  86         return;
  87     }
  88     if ( scalar keys %$sets >= $max_result_sets ) {
  89         $this->{ERR_CODE} = 112;
  90         $this->{ERR_STR}  = "Max number is $max_result_sets";
  91         return;
  92     }
  93     $sets->{$setname} = $rs;
  94     $this->{HITS} = $session->{HITS} = $hits;
  95     $session->{QUERY} = $query;
  96 }
  97
  98 sub FetchHandle {
  99     my $this     = shift;
 100     my $session  = $this->{HANDLE};
 101     my $setname  = $this->{SETNAME};
 102     my $req_form = $this->{REQ_FORM};
 103     my $offset   = $this->{OFFSET};
 104     my $sets     = $session->{SETS};
 105     my $hits     = $session->{HITS};
 106     my $rs;
 107     my $record;
 108
 109     if ( !defined( $rs = $sets->{$setname} ) ) {
 110         $this->{ERR_CODE} = 30;
 111         return;
 112     }
 113     if ( $offset > $hits ) {
 114         $this->{ERR_CODE} = 13;
 115         return;
 116     }
 117
 118         my $from = $rs->{from} || die "no from?";
 119
 120     $this->{BASENAME} = "HtmlZ3950";
 121
 122 #    if ( !defined($req_form) || ( $req_form eq &Net::Z3950::OID::xml ) )
 123     if (0)
 124     {    ## XML records
 125         $this->{REP_FORM} = &Net::Z3950::OID::xml;
 126         $this->{RECORD}   = '<xml>FIXME: not implementd</xml>';
 127     }
 128     elsif ( $req_form eq &Net::Z3950::OID::unimarc ) {  # FIXME convert to usmarc
 129         $this->{REP_FORM} = &Net::Z3950::OID::unimarc;
 130         $this->{RECORD} = $from->next_marc('unimarc');
 131     }
 132     elsif ( $req_form eq &Net::Z3950::OID::usmarc ) {   # FIXME convert to usmarc
 133         $this->{REP_FORM} = &Net::Z3950::OID::usmarc;
 134         $this->{RECORD} = $from->next_marc('usmarc');
 135     }
 136     else {    ## Unsupported record format
 137         $this->{ERR_CODE} = 239;
 138         $this->{ERR_STR}  = $req_form;
 139         return;
 140     }
 141     if ( $offset == $hits ) {
 142         $this->{LAST} = 1;
 143     }
 144     else {
 145         $this->{LAST} = 0;
 146     }
 147 }
 148
 149 sub CloseHandle {
 150     my $this = shift;
 151 }
 152
 153 my $z = new Net::Z3950::SimpleServer(
 154     INIT   => \&InitHandle,
 155     SEARCH => \&SearchHandle,
 156     FETCH  => \&FetchHandle,
 157     CLOSE  => \&CloseHandle
 158 );
 159 $z->launch_server( $0, @ARGV );
 160
 161 package Net::Z3950::RPN::And;
 162
 163 sub render {
 164     my $this = shift;
 165     return $this->[0]->render() . ' AND ' . $this->[1]->render();
 166 }
 167
 168 package Net::Z3950::RPN::Or;
 169
 170 sub render {
 171     my $this = shift;
 172     return $this->[0]->render() . ' OR ' . $this->[1]->render();
 173 }
 174
 175 package Net::Z3950::RPN::AndNot;
 176
 177 sub render {
 178     my $this = shift;
 179     return $this->[0]->render() . ' AND NOT ' . $this->[1]->render();
 180 }
 181
 182 package Net::Z3950::RPN::Term;
 183
 184 use Data::Dump qw(dump);
 185 use COBISS;
 186
 187 sub render {
 188         my ($this,$usemap) = @_;
 189
 190 warn "# render ", dump($this);
 191 warn "# usemap ", dump($usemap);
 192
 193     my $attributes = {};
 194     my $prefix     = "";
 195     foreach my $attr ( @{ $this->{attributes} } ) {
 196         my $type  = $attr->{attributeType};
 197         my $value = $attr->{attributeValue};
 198         $attributes->{$type} = $value;
 199     }
 200     if ( defined( my $use = $attributes->{1} ) ) {
 201         if ( defined( my $field = $usemap->{$use} ) ) {
 202             $prefix = $field;
 203         }
 204         else {
 205             die { errcode => 114, errstr => $use }; ## Unsupported use attribute
 206         }
 207     }
 208     if ( defined( my $rel = $attributes->{2} ) )
 209     {    ## No relation attributes supported
 210         if ( $rel != 3 ) {
 211             die { errcode => 117, errstr => $rel };
 212         }
 213     }
 214     if ( defined( my $pos = $attributes->{3} ) )
 215     {    ## No position attributes either
 216         if ( $pos != 3 ) {
 217             die { errcode => 119, errstr => $pos };
 218         }
 219     }
 220     if ( defined( my $struc = $attributes->{4} ) ) {    ## No structure
 221         if ( ( $struc != 1 ) && ( $struc != 2 ) ) {
 222             die { errcode => 118, errstr => $struc };
 223         }
 224     }
 225     if ( defined( $attributes->{5} ) ) {                ## No truncation
 226         die { errcode => 113, errstr => 5 };
 227     }
 228     my $comp = $attributes->{6};
 229     if ($prefix) {
 230         if ( defined($comp) && ( $comp >= 2 ) ) {
 231             $prefix = "all$prefix= ";
 232         }
 233         else {
 234             $prefix = "$prefix=";
 235         }
 236     }
 237
 238     my $q = $prefix . $this->{term};
 239         print "# q: $q\n";
 240         return $q;
 241 }
 242