server.pl

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