Line 0
Link Here
|
0 |
- |
1 |
#!/usr/bin/perl |
|
|
2 |
# |
3 |
# Copyright ByWater Solutions 2015 |
4 |
# |
5 |
# This file is part of Koha. |
6 |
# |
7 |
# Koha is free software; you can redistribute it and/or modify it under the |
8 |
# terms of the GNU General Public License as published by the Free Software |
9 |
# Foundation; either version 3 of the License, or (at your option) any later |
10 |
# version. |
11 |
# |
12 |
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY |
13 |
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR |
14 |
# A PARTICULAR PURPOSE. See the GNU General Public License for more details. |
15 |
# |
16 |
# You should have received a copy of the GNU General Public License along |
17 |
# with Koha; if not, write to the Free Software Foundation, Inc., |
18 |
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. |
19 |
|
20 |
use Modern::Perl; |
21 |
|
22 |
use C4::Biblio qw( GetMarcFromKohaField ); |
23 |
use C4::Circulation qw( GetTransfers ); |
24 |
use C4::Context; |
25 |
use C4::Koha qw( GetAuthorisedValues ); |
26 |
use C4::Items qw( GetItem ); |
27 |
use C4::Reserves qw( GetReserveStatus ); |
28 |
use C4::Search qw(); |
29 |
use Koha; |
30 |
use Koha::Logger; |
31 |
|
32 |
use Carp; |
33 |
use Getopt::Long; |
34 |
use Net::Z3950::SimpleServer; |
35 |
use Pod::Usage; |
36 |
use ZOOM; |
37 |
|
38 |
use constant { |
39 |
UNIMARC_OID => '1.2.840.10003.5.1', |
40 |
USMARC_OID => '1.2.840.10003.5.10', |
41 |
MARCXML_OID => '1.2.840.10003.5.109.10' |
42 |
}; |
43 |
|
44 |
use constant { |
45 |
ERR_TEMPORARY_ERROR => 2, |
46 |
ERR_PRESENT_OUT_OF_RANGE => 13, |
47 |
ERR_RECORD_TOO_LARGE => 16, |
48 |
ERR_NO_SUCH_RESULTSET => 30, |
49 |
ERR_SYNTAX_UNSUPPORTED => 230, |
50 |
ERR_DB_DOES_NOT_EXIST => 235, |
51 |
}; |
52 |
|
53 |
=head1 SYNOPSIS |
54 |
|
55 |
z3950_responder.pl [-a <pdufile>] [-v <loglevel>] [-l <logfile>] [-u <user>] |
56 |
[-c <config>] [-t <minutes>] [-k <kilobytes>] [-d <daemon>] [-p <pidfile>] |
57 |
[-C certfile] [-zKiDST1] [-m <time-format>] [-w <directory>] [--debug] |
58 |
[--add-item-status=SUBFIELD] [--prefetch=NUM_RECORDS] |
59 |
[<listener-addr>... ] |
60 |
|
61 |
=head1 OPTIONS |
62 |
|
63 |
=over 8 |
64 |
|
65 |
=item B<--debug> |
66 |
|
67 |
Turns on debug logging to the screen, and turns on single-process mode. |
68 |
|
69 |
=item B<--add-item-status=SUBFIELD> |
70 |
|
71 |
If given, adds item status information to the given subfield. |
72 |
|
73 |
=item B<--prefetch=NUM_RECORDS> |
74 |
|
75 |
Number of records to prefetch from Zebra. Defaults to 20. |
76 |
|
77 |
=back |
78 |
|
79 |
=head1 CONFIGURATION |
80 |
|
81 |
The item status strings added by B<--add-item-status> can be configured with the B<Z3950_STATUS> |
82 |
authorized value, using the following keys: |
83 |
|
84 |
=over 4 |
85 |
|
86 |
=item AVAILABLE |
87 |
|
88 |
=item CHECKED_OUT |
89 |
|
90 |
=item LOST |
91 |
|
92 |
=item NOT_FOR_LOAN |
93 |
|
94 |
=item DAMAGED |
95 |
|
96 |
=item WITHDRAWN |
97 |
|
98 |
=item IN_TRANSIT |
99 |
|
100 |
=item ON_HOLD |
101 |
|
102 |
=back |
103 |
|
104 |
=cut |
105 |
|
106 |
my $debug = 0; |
107 |
my $add_item_status_subfield; |
108 |
my $prefetch = 20; |
109 |
my @yaz_options; |
110 |
|
111 |
sub add_yaz_option { |
112 |
my ( $opt_name, $opt_value ) = @_; |
113 |
|
114 |
push @yaz_options, "-$opt_name", "$opt_value"; |
115 |
} |
116 |
|
117 |
GetOptions( |
118 |
'--debug' => \$debug, |
119 |
'--add-item-status=s' => \$add_item_status_subfield, |
120 |
'--prefetch=i' => \$prefetch, |
121 |
# Pass through YAZ options. |
122 |
'a=s' => \&add_yaz_option, |
123 |
'v=s' => \&add_yaz_option, |
124 |
'l=s' => \&add_yaz_option, |
125 |
'u=s' => \&add_yaz_option, |
126 |
'c=s' => \&add_yaz_option, |
127 |
't=s' => \&add_yaz_option, |
128 |
'k=s' => \&add_yaz_option, |
129 |
'd=s' => \&add_yaz_option, |
130 |
'p=s' => \&add_yaz_option, |
131 |
'C=s' => \&add_yaz_option, |
132 |
'm=s' => \&add_yaz_option, |
133 |
'w=s' => \&add_yaz_option, |
134 |
'z' => \&add_yaz_option, |
135 |
'K' => \&add_yaz_option, |
136 |
'i' => \&add_yaz_option, |
137 |
'D' => \&add_yaz_option, |
138 |
'S' => \&add_yaz_option, |
139 |
'T' => \&add_yaz_option, |
140 |
'1' => \&add_yaz_option |
141 |
) || pod2usage( -exitval => 1 ); |
142 |
|
143 |
unshift @ARGV, @yaz_options; |
144 |
|
145 |
# Turn off Yaz's built-in logging (can be turned back on if desired). |
146 |
unshift @ARGV, '-v', 'none'; |
147 |
|
148 |
# If requested, turn on debugging. |
149 |
|
150 |
if ( $debug ) { |
151 |
# Turn on single-process mode. |
152 |
unshift @ARGV, '-S'; |
153 |
} |
154 |
|
155 |
my ($item_tag, $itemnumber_subfield) = GetMarcFromKohaField("items.itemnumber",''); |
156 |
|
157 |
# We hardcode the strings for English so SOMETHING will work if the authorized value doesn't exist. |
158 |
|
159 |
my $status_strings = { |
160 |
AVAILABLE => 'Available', |
161 |
CHECKED_OUT => 'Checked Out', |
162 |
LOST => 'Lost', |
163 |
NOT_FOR_LOAN => 'Not for Loan', |
164 |
DAMAGED => 'Damaged', |
165 |
WITHDRAWN => 'Withdrawn', |
166 |
IN_TRANSIT => 'In Transit', |
167 |
ON_HOLD => 'On Hold', |
168 |
}; |
169 |
|
170 |
foreach my $val ( @{ GetAuthorisedValues( 'Z3950_STATUS' ) } ) { |
171 |
$status_strings->{ $val->{authorised_value} } = $val->{lib}; |
172 |
} |
173 |
|
174 |
# Create and start the server. |
175 |
|
176 |
my $z = Net::Z3950::SimpleServer->new( |
177 |
# Global context object. This is shared between processes, so it should not be modified. |
178 |
GHANDLE => { |
179 |
add_item_status_subfield => $add_item_status_subfield, |
180 |
debug => $debug, |
181 |
item_tag => $item_tag, |
182 |
itemnumber_subfield => $itemnumber_subfield, |
183 |
num_to_prefetch => $prefetch, |
184 |
status_strings => $status_strings, |
185 |
}, |
186 |
INIT => \&init_handler, |
187 |
SEARCH => \&search_handler, |
188 |
PRESENT => \&present_handler, |
189 |
FETCH => \&fetch_handler, |
190 |
CLOSE => \&close_handler, |
191 |
); |
192 |
|
193 |
$z->launch_server('z3950_responder.pl', @ARGV); |
194 |
|
195 |
sub _set_error { |
196 |
my ( $args, $code, $msg ) = @_; |
197 |
( $args->{ERR_CODE}, $args->{ERR_STR} ) = ( $code, $msg ); |
198 |
|
199 |
$args->{HANDLE}->{logger}->info("[$args->{HANDLE}->{peer}] returning error $code: $msg"); |
200 |
} |
201 |
|
202 |
sub _set_error_from_zoom { |
203 |
my ( $args, $exception ) = @_; |
204 |
|
205 |
_set_error( $args, ERR_TEMPORARY_ERROR, 'Cannot connect to upstream server' ); |
206 |
$args->{HANDLE}->{logger}->error( |
207 |
"Zebra upstream error: " . |
208 |
$exception->message() . " (" . |
209 |
$exception->code() . ") " . |
210 |
( $exception->addinfo() // '' ) . " " . |
211 |
$exception->diagset() |
212 |
); |
213 |
} |
214 |
|
215 |
# This code originally went through C4::Search::getRecords, but had to use so many escape hatches |
216 |
# that it was easier to directly connect to Zebra. |
217 |
sub _start_search { |
218 |
my ( $config, $session, $args, $in_retry ) = @_; |
219 |
|
220 |
my $database = $args->{DATABASES}->[0]; |
221 |
my ( $connection, $results ); |
222 |
|
223 |
eval { |
224 |
$connection = C4::Context->Zconn( |
225 |
# We're depending on the caller to have done some validation. |
226 |
$database eq 'biblios' ? 'biblioserver' : 'authorityserver', |
227 |
0 # No, no async, doesn't really help much for single-server searching |
228 |
); |
229 |
|
230 |
$results = $connection->search_pqf( $args->{QUERY} ); |
231 |
|
232 |
$session->{logger}->debug("[$session->{peer}] retry successful") if ($in_retry); |
233 |
}; |
234 |
if ($@) { |
235 |
die $@ if ( ref($@) ne 'ZOOM::Exception' ); |
236 |
|
237 |
if ( $@->diagset() eq 'ZOOM' && $@->code() == 10004 && !$in_retry ) { |
238 |
$session->{logger}->debug("[$session->{peer}] upstream server lost connection, retrying"); |
239 |
return _start_search( $config, $session, $args, $in_retry ); |
240 |
} |
241 |
|
242 |
_set_error_from_zoom( $args, $@ ); |
243 |
$connection = undef; |
244 |
} |
245 |
|
246 |
return ( $connection, $results, $results ? $results->size() : -1 ); |
247 |
} |
248 |
|
249 |
sub _prefetch_records { |
250 |
my ( $session, $resultset, $args, $start, $num_records ) = @_; |
251 |
|
252 |
eval { |
253 |
if ( $start + $num_records >= $resultset->{results}->size() ) { |
254 |
$num_records = $resultset->{results}->size() - $start; |
255 |
} |
256 |
|
257 |
$session->{logger}->debug("[$session->{peer}] prefetching $num_records records starting at $start"); |
258 |
|
259 |
$resultset->{results}->records( $start, $num_records, 0 ); |
260 |
}; |
261 |
if ($@) { |
262 |
die $@ if ( ref($@) ne 'ZOOM::Exception' ); |
263 |
_set_error_from_zoom( $args, $@ ); |
264 |
return; |
265 |
} |
266 |
} |
267 |
|
268 |
sub _fetch_record { |
269 |
my ( $session, $resultset, $args, $index, $num_to_prefetch ) = @_; |
270 |
|
271 |
my $record; |
272 |
|
273 |
eval { |
274 |
if ( !$resultset->{results}->record_immediate( $index ) ) { |
275 |
my $start = int( $index / $num_to_prefetch ) * $num_to_prefetch; |
276 |
|
277 |
if ( $start + $num_to_prefetch >= $resultset->{results}->size() ) { |
278 |
$num_to_prefetch = $resultset->{results}->size() - $start; |
279 |
} |
280 |
|
281 |
$session->{logger}->debug("[$session->{peer}] fetch uncached, fetching $num_to_prefetch records starting at $start"); |
282 |
|
283 |
$resultset->{results}->records( $start, $num_to_prefetch, 0 ); |
284 |
} |
285 |
|
286 |
$record = $resultset->{results}->record_immediate( $index )->raw(); |
287 |
}; |
288 |
if ($@) { |
289 |
die $@ if ( ref($@) ne 'ZOOM::Exception' ); |
290 |
_set_error_from_zoom( $args, $@ ); |
291 |
return; |
292 |
} else { |
293 |
return $record; |
294 |
} |
295 |
} |
296 |
|
297 |
sub _close_resultset { |
298 |
my ( $resultset ) = @_; |
299 |
|
300 |
$resultset->{results}->destroy(); |
301 |
# We can't destroy the connection, as it may be cached |
302 |
} |
303 |
|
304 |
sub init_handler { |
305 |
# Called when the client first connects. |
306 |
my ( $args ) = @_; |
307 |
|
308 |
my $config = $args->{GHANDLE}; |
309 |
|
310 |
# This holds all of the per-connection state. |
311 |
my $session = { |
312 |
logger => Koha::Logger->get({ interface => 'z3950' }), |
313 |
peer => $args->{PEER_NAME}, |
314 |
resultsets => {}, |
315 |
}; |
316 |
|
317 |
if ( $config->{debug} ) { |
318 |
$session->{logger}->debug_to_screen(); |
319 |
} |
320 |
|
321 |
$args->{HANDLE} = $session; |
322 |
|
323 |
$args->{IMP_NAME} = "Koha"; |
324 |
$args->{IMP_VER} = Koha::version; |
325 |
|
326 |
$session->{logger}->info("[$session->{peer}] connected"); |
327 |
} |
328 |
|
329 |
sub search_handler { |
330 |
# Called when search is first sent. |
331 |
my ( $args ) = @_; |
332 |
|
333 |
my $database = $args->{DATABASES}->[0]; |
334 |
if ( $database !~ /^(biblios|authorities)$/ ) { |
335 |
_set_error( ERR_DB_DOES_NOT_EXIST, 'No such database' ); |
336 |
return; |
337 |
} |
338 |
|
339 |
my $config = $args->{GHANDLE}; |
340 |
my $session = $args->{HANDLE}; |
341 |
|
342 |
my $query = $args->{QUERY}; |
343 |
$session->{logger}->info("[$session->{peer}] received search for '$query', (RS $args->{SETNAME})"); |
344 |
|
345 |
my ( $connection, $results, $num_hits ) = _start_search( $config, $session, $args ); |
346 |
return unless $connection; |
347 |
|
348 |
$args->{HITS} = $num_hits; |
349 |
my $resultset = $session->{resultsets}->{ $args->{SETNAME} } = { |
350 |
database => $database, |
351 |
connection => $connection, |
352 |
results => $results, |
353 |
query => $args->{QUERY}, |
354 |
hits => $args->{HITS}, |
355 |
}; |
356 |
} |
357 |
|
358 |
sub _check_fetch { |
359 |
my ( $args, $resultset, $offset, $num_records ) = @_; |
360 |
|
361 |
if ( !defined( $resultset ) ) { |
362 |
_set_error( $args, ERR_NO_SUCH_RESULTSET, 'No such resultset' ); |
363 |
return 0; |
364 |
} |
365 |
|
366 |
if ( $offset + $num_records > $resultset->{hits} ) { |
367 |
_set_error( $args, ERR_PRESENT_OUT_OF_RANGE, 'Fetch request out of range' ); |
368 |
return 0; |
369 |
} |
370 |
|
371 |
return 1; |
372 |
} |
373 |
|
374 |
sub present_handler { |
375 |
# Called when a set of records is requested. |
376 |
my ( $args ) = @_; |
377 |
my $session = $args->{HANDLE}; |
378 |
|
379 |
$session->{logger}->debug("[$session->{peer}] received present for $args->{SETNAME}, $args->{START}+$args->{NUMBER}"); |
380 |
|
381 |
my $resultset = $session->{resultsets}->{ $args->{SETNAME} }; |
382 |
# The offset comes across 1-indexed. |
383 |
my $offset = $args->{START} - 1; |
384 |
|
385 |
return unless _check_fetch( $args, $resultset, $offset, $args->{NUMBER} ); |
386 |
|
387 |
# Ignore if request is only for one record; our own prefetching will probably do a better job. |
388 |
_prefetch_records( $session, $resultset, $args, $offset, $args->{NUMBER} ) if ( $args->{NUMBER} > 1 ); |
389 |
} |
390 |
|
391 |
sub fetch_handler { |
392 |
# Called when a given record is requested. |
393 |
my ( $args ) = @_; |
394 |
my $config = $args->{GHANDLE}; |
395 |
my $session = $args->{HANDLE}; |
396 |
|
397 |
$session->{logger}->debug("[$session->{peer}] received fetch for $args->{SETNAME}, record $args->{OFFSET}"); |
398 |
my $form_oid = $args->{REQ_FORM} // ''; |
399 |
my $composition = $args->{COMP} // ''; |
400 |
$session->{logger}->debug("[$session->{peer}] form OID $form_oid, composition $composition"); |
401 |
|
402 |
my $resultset = $session->{resultsets}->{ $args->{SETNAME} }; |
403 |
# The offset comes across 1-indexed. |
404 |
my $offset = $args->{OFFSET} - 1; |
405 |
|
406 |
return unless _check_fetch( $args, $resultset, $offset, 1 ); |
407 |
|
408 |
$args->{LAST} = 1 if ( $offset == $resultset->{hits} - 1 ); |
409 |
|
410 |
my $record = _fetch_record( $session, $resultset, $args, $offset, $config->{num_to_prefetch} ); |
411 |
return unless $record; |
412 |
|
413 |
$record = C4::Search::new_record_from_zebra( |
414 |
$resultset->{database} eq 'biblios' ? 'biblioserver' : 'authorityserver', |
415 |
$record |
416 |
); |
417 |
|
418 |
if ( $config->{add_item_status_subfield} ) { |
419 |
my $tag = $config->{item_tag}; |
420 |
my $itemnumber_subfield = $config->{itemnumber_subfield}; |
421 |
my $add_subfield = $config->{add_item_status_subfield}; |
422 |
my $status_strings = $config->{status_strings}; |
423 |
|
424 |
foreach my $field ( $record->field($tag) ) { |
425 |
my $itemnumber = $field->subfield($itemnumber_subfield); |
426 |
next unless $itemnumber; |
427 |
|
428 |
my $item = GetItem( $itemnumber ); |
429 |
my @statuses; |
430 |
|
431 |
if ( $item->{onloan} ) { |
432 |
push @statuses, $status_strings->{CHECKED_OUT}; |
433 |
} |
434 |
|
435 |
if ( $item->{itemlost} ) { |
436 |
push @statuses, $status_strings->{LOST}; |
437 |
} |
438 |
|
439 |
if ( $item->{notforloan} ) { |
440 |
push @statuses, $status_strings->{NOT_FOR_LOAN}; |
441 |
} |
442 |
|
443 |
if ( $item->{damaged} ) { |
444 |
push @statuses, $status_strings->{DAMAGED}; |
445 |
} |
446 |
|
447 |
if ( $item->{withdrawn} ) { |
448 |
push @statuses, $status_strings->{WITHDRAWN}; |
449 |
} |
450 |
|
451 |
if ( scalar( GetTransfers( $itemnumber ) ) ) { |
452 |
push @statuses, $status_strings->{IN_TRANSIT}; |
453 |
} |
454 |
|
455 |
if ( GetReserveStatus( $itemnumber ) ne '' ) { |
456 |
push @statuses, $status_strings->{ON_HOLD}; |
457 |
} |
458 |
|
459 |
$field->delete_subfield( code => $itemnumber_subfield ); |
460 |
$field->add_subfields( $add_subfield, @statuses ? join( ', ', @statuses ) : $status_strings->{AVAILABLE} ); |
461 |
} |
462 |
} |
463 |
|
464 |
if ( $form_oid eq MARCXML_OID && $composition eq 'marcxml' ) { |
465 |
$args->{RECORD} = $record->as_xml_record(); |
466 |
} elsif ( ( $form_oid eq USMARC_OID || $form_oid eq UNIMARC_OID ) && ( !$composition || $composition eq 'F' ) ) { |
467 |
$args->{RECORD} = $record->as_usmarc(); |
468 |
} else { |
469 |
_set_error( $args, ERR_SYNTAX_UNSUPPORTED, "Unsupported syntax/composition $form_oid/$composition" ); |
470 |
return; |
471 |
} |
472 |
} |
473 |
|
474 |
sub close_handler { |
475 |
my ( $args ) = @_; |
476 |
|
477 |
my $session = $args->{HANDLE}; |
478 |
|
479 |
foreach my $resultset ( values %{ $session->{resultsets} } ) { |
480 |
_close_resultset( $resultset ); |
481 |
} |
482 |
} |