collect results to support offset in fetch record
[Biblio-Z3950.git] / 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} = "$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         $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                 results => [ undef ], # we don't use 0 element
82     };
83     my $sets = $session->{SETS};
84
85     if ( defined( $sets->{$setname} ) && !$repl_set ) {
86         $this->{ERR_CODE} = 21;
87         return;
88     }
89     if ( scalar keys %$sets >= $max_result_sets ) {
90         $this->{ERR_CODE} = 112;
91         $this->{ERR_STR}  = "Max number is $max_result_sets";
92         return;
93     }
94     $sets->{$setname} = $rs;
95     $this->{HITS} = $session->{HITS} = $hits;
96     $session->{QUERY} = $query;
97 }
98
99 sub FetchHandle {
100     my $this     = shift;
101     my $session  = $this->{HANDLE};
102     my $setname  = $this->{SETNAME};
103     my $req_form = $this->{REQ_FORM};
104     my $offset   = $this->{OFFSET};
105     my $sets     = $session->{SETS};
106     my $hits     = $session->{HITS};
107     my $rs;
108     my $record;
109
110     if ( !defined( $rs = $sets->{$setname} ) ) {
111         $this->{ERR_CODE} = 30;
112         return;
113     }
114     if ( $offset > $hits ) {
115         $this->{ERR_CODE} = 13;
116         return;
117     }
118
119     $this->{BASENAME} = "HtmlZ3950";
120
121         my $format = 'usmarc';
122
123 #    if ( !defined($req_form) || ( $req_form eq &Net::Z3950::OID::xml ) )
124     if (0)
125     {    ## XML records
126         $this->{REP_FORM} = &Net::Z3950::OID::xml;
127         $this->{RECORD}   = '<xml>FIXME: not implementd</xml>';
128     }
129     elsif ( $req_form eq &Net::Z3950::OID::unimarc ) {  # FIXME convert to usmarc
130         $this->{REP_FORM} = &Net::Z3950::OID::unimarc;
131                 $format = 'unimarc';
132     }
133     elsif ( $req_form eq &Net::Z3950::OID::usmarc ) {   # FIXME convert to usmarc
134         $this->{REP_FORM} = &Net::Z3950::OID::usmarc;
135                 $format = 'usmarc';
136     }
137     else {    ## Unsupported record format
138         $this->{ERR_CODE} = 239;
139         $this->{ERR_STR}  = $req_form;
140         return;
141     }
142
143
144         my $from = $rs->{from} || die "no from?";
145         # fetch records up to offset
146         while(  $#{ $rs->{results} } < $offset ) {
147                 push @{ $rs->{results} }, $from->next_marc;
148                 warn "# rs result ", $#{ $rs->{results} }, " $format\n";
149         }
150
151         my $id = $rs->{results}->[$offset] || die "no id for record $offset in ",Dumper( $rs->{results} );
152
153         my $path = "marc/$id.$format";
154         if ( ! -e $path ) {
155                 ## Unsupported record format
156         $this->{ERR_CODE} = 239;
157         $this->{ERR_STR}  = $req_form;
158         return;
159     }
160
161         {
162                 open(my $in, '<', $path) || die "$path: $!";
163                 local $/ = undef;
164                 my $marc = <$in>;
165                 close($in);
166                 $this->{RECORD} = $in;
167         }
168
169
170     if ( $offset == $hits ) {
171         $this->{LAST} = 1;
172     }
173     else {
174         $this->{LAST} = 0;
175     }
176 }
177
178 sub CloseHandle {
179     my $this = shift;
180 }
181
182 my $z = new Net::Z3950::SimpleServer(
183     INIT   => \&InitHandle,
184     SEARCH => \&SearchHandle,
185     FETCH  => \&FetchHandle,
186     CLOSE  => \&CloseHandle
187 );
188 $z->launch_server( $0, @ARGV );
189
190 package Net::Z3950::RPN::And;
191
192 sub render {
193     my $this = shift;
194     return $this->[0]->render() . ' AND ' . $this->[1]->render();
195 }
196
197 package Net::Z3950::RPN::Or;
198
199 sub render {
200     my $this = shift;
201     return $this->[0]->render() . ' OR ' . $this->[1]->render();
202 }
203
204 package Net::Z3950::RPN::AndNot;
205
206 sub render {
207     my $this = shift;
208     return $this->[0]->render() . ' AND NOT ' . $this->[1]->render();
209 }
210
211 package Net::Z3950::RPN::Term;
212
213 use Data::Dump qw(dump);
214 use COBISS;
215
216 sub render {
217         my ($this,$usemap) = @_;
218
219 warn "# render ", dump($this);
220 warn "# usemap ", dump($usemap);
221
222     my $attributes = {};
223     my $prefix     = "";
224     foreach my $attr ( @{ $this->{attributes} } ) {
225         my $type  = $attr->{attributeType};
226         my $value = $attr->{attributeValue};
227         $attributes->{$type} = $value;
228     }
229     if ( defined( my $use = $attributes->{1} ) ) {
230         if ( defined( my $field = $usemap->{$use} ) ) {
231             $prefix = $field;
232         }
233         else {
234             die { errcode => 114, errstr => $use }; ## Unsupported use attribute
235         }
236     }
237     if ( defined( my $rel = $attributes->{2} ) )
238     {    ## No relation attributes supported
239         if ( $rel != 3 ) {
240             die { errcode => 117, errstr => $rel };
241         }
242     }
243     if ( defined( my $pos = $attributes->{3} ) )
244     {    ## No position attributes either
245         if ( $pos != 3 ) {
246             die { errcode => 119, errstr => $pos };
247         }
248     }
249     if ( defined( my $struc = $attributes->{4} ) ) {    ## No structure
250         if ( ( $struc != 1 ) && ( $struc != 2 ) ) {
251             die { errcode => 118, errstr => $struc };
252         }
253     }
254     if ( defined( $attributes->{5} ) ) {                ## No truncation
255         die { errcode => 113, errstr => 5 };
256     }
257     my $comp = $attributes->{6};
258     if ($prefix) {
259         if ( defined($comp) && ( $comp >= 2 ) ) {
260             $prefix = "all$prefix= ";
261         }
262         else {
263             $prefix = "$prefix=";
264         }
265     }
266
267     my $q = $prefix . $this->{term};
268         print "# q: $q\n";
269         return $q;
270 }
271