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