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