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 [-h|--help] [--man] [-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<--help> |
66 |
|
67 |
Prints a brief usage message and exits. |
68 |
|
69 |
=item B<--man> |
70 |
|
71 |
Displays manual page and exits. |
72 |
|
73 |
=item B<--debug> |
74 |
|
75 |
Turns on debug logging to the screen, and turns on single-process mode. |
76 |
|
77 |
=item B<--add-item-status=SUBFIELD> |
78 |
|
79 |
If given, adds item status information to the given subfield. |
80 |
|
81 |
=item B<--add-status-multi-subfield> |
82 |
|
83 |
With the above, instead of putting multiple item statuses in one subfield, adds a subfield for each |
84 |
status string. |
85 |
|
86 |
=item B<--prefetch=NUM_RECORDS> |
87 |
|
88 |
Number of records to prefetch from Zebra. Defaults to 20. |
89 |
|
90 |
=back |
91 |
|
92 |
=head1 CONFIGURATION |
93 |
|
94 |
The item status strings added by B<--add-item-status> can be configured with the B<Z3950_STATUS> |
95 |
authorized value, using the following keys: |
96 |
|
97 |
=over 4 |
98 |
|
99 |
=item AVAILABLE |
100 |
|
101 |
=item CHECKED_OUT |
102 |
|
103 |
=item LOST |
104 |
|
105 |
=item NOT_FOR_LOAN |
106 |
|
107 |
=item DAMAGED |
108 |
|
109 |
=item WITHDRAWN |
110 |
|
111 |
=item IN_TRANSIT |
112 |
|
113 |
=item ON_HOLD |
114 |
|
115 |
=back |
116 |
|
117 |
=cut |
118 |
|
119 |
my $add_item_status_subfield; |
120 |
my $add_status_multi_subfield; |
121 |
my $debug = 0; |
122 |
my $help; |
123 |
my $man; |
124 |
my $prefetch = 20; |
125 |
my @yaz_options; |
126 |
|
127 |
sub add_yaz_option { |
128 |
my ( $opt_name, $opt_value ) = @_; |
129 |
|
130 |
push @yaz_options, "-$opt_name", "$opt_value"; |
131 |
} |
132 |
|
133 |
GetOptions( |
134 |
'-h|help' => \$help, |
135 |
'--man' => \$man, |
136 |
'--debug' => \$debug, |
137 |
'--add-item-status=s' => \$add_item_status_subfield, |
138 |
'--add-status-multi-subfield' => \$add_status_multi_subfield, |
139 |
'--prefetch=i' => \$prefetch, |
140 |
# Pass through YAZ options. |
141 |
'a=s' => \&add_yaz_option, |
142 |
'v=s' => \&add_yaz_option, |
143 |
'l=s' => \&add_yaz_option, |
144 |
'u=s' => \&add_yaz_option, |
145 |
'c=s' => \&add_yaz_option, |
146 |
't=s' => \&add_yaz_option, |
147 |
'k=s' => \&add_yaz_option, |
148 |
'd=s' => \&add_yaz_option, |
149 |
'p=s' => \&add_yaz_option, |
150 |
'C=s' => \&add_yaz_option, |
151 |
'm=s' => \&add_yaz_option, |
152 |
'w=s' => \&add_yaz_option, |
153 |
'z' => \&add_yaz_option, |
154 |
'K' => \&add_yaz_option, |
155 |
'i' => \&add_yaz_option, |
156 |
'D' => \&add_yaz_option, |
157 |
'S' => \&add_yaz_option, |
158 |
'T' => \&add_yaz_option, |
159 |
'1' => \&add_yaz_option |
160 |
) || pod2usage(2); |
161 |
|
162 |
pod2usage(1) if $help; |
163 |
pod2usage( -verbose => 2 ) if $man; |
164 |
|
165 |
unshift @ARGV, @yaz_options; |
166 |
|
167 |
# Turn off Yaz's built-in logging (can be turned back on if desired). |
168 |
unshift @ARGV, '-v', 'none'; |
169 |
|
170 |
# If requested, turn on debugging. |
171 |
|
172 |
if ( $debug ) { |
173 |
# Turn on single-process mode. |
174 |
unshift @ARGV, '-S'; |
175 |
} |
176 |
|
177 |
my ($item_tag, $itemnumber_subfield) = GetMarcFromKohaField("items.itemnumber",''); |
178 |
|
179 |
# We hardcode the strings for English so SOMETHING will work if the authorized value doesn't exist. |
180 |
|
181 |
my $status_strings = { |
182 |
AVAILABLE => 'Available', |
183 |
CHECKED_OUT => 'Checked Out', |
184 |
LOST => 'Lost', |
185 |
NOT_FOR_LOAN => 'Not for Loan', |
186 |
DAMAGED => 'Damaged', |
187 |
WITHDRAWN => 'Withdrawn', |
188 |
IN_TRANSIT => 'In Transit', |
189 |
ON_HOLD => 'On Hold', |
190 |
}; |
191 |
|
192 |
foreach my $val ( @{ GetAuthorisedValues( 'Z3950_STATUS' ) } ) { |
193 |
$status_strings->{ $val->{authorised_value} } = $val->{lib}; |
194 |
} |
195 |
|
196 |
# Create and start the server. |
197 |
|
198 |
my $z = Net::Z3950::SimpleServer->new( |
199 |
# Global context object. This is shared between processes, so it should not be modified. |
200 |
GHANDLE => { |
201 |
add_item_status_subfield => $add_item_status_subfield, |
202 |
add_status_multi_subfield => $add_status_multi_subfield, |
203 |
debug => $debug, |
204 |
item_tag => $item_tag, |
205 |
itemnumber_subfield => $itemnumber_subfield, |
206 |
num_to_prefetch => $prefetch, |
207 |
status_strings => $status_strings, |
208 |
}, |
209 |
INIT => \&init_handler, |
210 |
SEARCH => \&search_handler, |
211 |
PRESENT => \&present_handler, |
212 |
FETCH => \&fetch_handler, |
213 |
CLOSE => \&close_handler, |
214 |
); |
215 |
|
216 |
$z->launch_server('z3950_responder.pl', @ARGV); |
217 |
|
218 |
sub _set_error { |
219 |
my ( $args, $code, $msg ) = @_; |
220 |
( $args->{ERR_CODE}, $args->{ERR_STR} ) = ( $code, $msg ); |
221 |
|
222 |
$args->{HANDLE}->{logger}->info("[$args->{HANDLE}->{peer}] returning error $code: $msg"); |
223 |
} |
224 |
|
225 |
sub _set_error_from_zoom { |
226 |
my ( $args, $exception ) = @_; |
227 |
|
228 |
_set_error( $args, ERR_TEMPORARY_ERROR, 'Cannot connect to upstream server' ); |
229 |
$args->{HANDLE}->{logger}->error( |
230 |
"Zebra upstream error: " . |
231 |
$exception->message() . " (" . |
232 |
$exception->code() . ") " . |
233 |
( $exception->addinfo() // '' ) . " " . |
234 |
$exception->diagset() |
235 |
); |
236 |
} |
237 |
|
238 |
# This code originally went through C4::Search::getRecords, but had to use so many escape hatches |
239 |
# that it was easier to directly connect to Zebra. |
240 |
sub _start_search { |
241 |
my ( $config, $session, $args, $in_retry ) = @_; |
242 |
|
243 |
my $database = $args->{DATABASES}->[0]; |
244 |
my ( $connection, $results ); |
245 |
|
246 |
eval { |
247 |
$connection = C4::Context->Zconn( |
248 |
# We're depending on the caller to have done some validation. |
249 |
$database eq 'biblios' ? 'biblioserver' : 'authorityserver', |
250 |
0 # No, no async, doesn't really help much for single-server searching |
251 |
); |
252 |
|
253 |
$results = $connection->search_pqf( $args->{QUERY} ); |
254 |
|
255 |
$session->{logger}->debug("[$session->{peer}] retry successful") if ($in_retry); |
256 |
}; |
257 |
if ($@) { |
258 |
die $@ if ( ref($@) ne 'ZOOM::Exception' ); |
259 |
|
260 |
if ( $@->diagset() eq 'ZOOM' && $@->code() == 10004 && !$in_retry ) { |
261 |
$session->{logger}->debug("[$session->{peer}] upstream server lost connection, retrying"); |
262 |
return _start_search( $config, $session, $args, $in_retry ); |
263 |
} |
264 |
|
265 |
_set_error_from_zoom( $args, $@ ); |
266 |
$connection = undef; |
267 |
} |
268 |
|
269 |
return ( $connection, $results, $results ? $results->size() : -1 ); |
270 |
} |
271 |
|
272 |
sub _prefetch_records { |
273 |
my ( $session, $resultset, $args, $start, $num_records ) = @_; |
274 |
|
275 |
eval { |
276 |
if ( $start + $num_records >= $resultset->{results}->size() ) { |
277 |
$num_records = $resultset->{results}->size() - $start; |
278 |
} |
279 |
|
280 |
$session->{logger}->debug("[$session->{peer}] prefetching $num_records records starting at $start"); |
281 |
|
282 |
$resultset->{results}->records( $start, $num_records, 0 ); |
283 |
}; |
284 |
if ($@) { |
285 |
die $@ if ( ref($@) ne 'ZOOM::Exception' ); |
286 |
_set_error_from_zoom( $args, $@ ); |
287 |
return; |
288 |
} |
289 |
} |
290 |
|
291 |
sub _fetch_record { |
292 |
my ( $session, $resultset, $args, $index, $num_to_prefetch ) = @_; |
293 |
|
294 |
my $record; |
295 |
|
296 |
eval { |
297 |
if ( !$resultset->{results}->record_immediate( $index ) ) { |
298 |
my $start = int( $index / $num_to_prefetch ) * $num_to_prefetch; |
299 |
|
300 |
if ( $start + $num_to_prefetch >= $resultset->{results}->size() ) { |
301 |
$num_to_prefetch = $resultset->{results}->size() - $start; |
302 |
} |
303 |
|
304 |
$session->{logger}->debug("[$session->{peer}] fetch uncached, fetching $num_to_prefetch records starting at $start"); |
305 |
|
306 |
$resultset->{results}->records( $start, $num_to_prefetch, 0 ); |
307 |
} |
308 |
|
309 |
$record = $resultset->{results}->record_immediate( $index )->raw(); |
310 |
}; |
311 |
if ($@) { |
312 |
die $@ if ( ref($@) ne 'ZOOM::Exception' ); |
313 |
_set_error_from_zoom( $args, $@ ); |
314 |
return; |
315 |
} else { |
316 |
return $record; |
317 |
} |
318 |
} |
319 |
|
320 |
sub _close_resultset { |
321 |
my ( $resultset ) = @_; |
322 |
|
323 |
$resultset->{results}->destroy(); |
324 |
# We can't destroy the connection, as it may be cached |
325 |
} |
326 |
|
327 |
sub init_handler { |
328 |
# Called when the client first connects. |
329 |
my ( $args ) = @_; |
330 |
|
331 |
my $config = $args->{GHANDLE}; |
332 |
|
333 |
# This holds all of the per-connection state. |
334 |
my $session = { |
335 |
logger => Koha::Logger->get({ interface => 'z3950' }), |
336 |
peer => $args->{PEER_NAME}, |
337 |
resultsets => {}, |
338 |
}; |
339 |
|
340 |
if ( $config->{debug} ) { |
341 |
$session->{logger}->debug_to_screen(); |
342 |
} |
343 |
|
344 |
$args->{HANDLE} = $session; |
345 |
|
346 |
$args->{IMP_NAME} = "Koha"; |
347 |
$args->{IMP_VER} = Koha::version; |
348 |
|
349 |
$session->{logger}->info("[$session->{peer}] connected"); |
350 |
} |
351 |
|
352 |
sub search_handler { |
353 |
# Called when search is first sent. |
354 |
my ( $args ) = @_; |
355 |
|
356 |
my $database = $args->{DATABASES}->[0]; |
357 |
if ( $database !~ /^(biblios|authorities)$/ ) { |
358 |
_set_error( ERR_DB_DOES_NOT_EXIST, 'No such database' ); |
359 |
return; |
360 |
} |
361 |
|
362 |
my $config = $args->{GHANDLE}; |
363 |
my $session = $args->{HANDLE}; |
364 |
|
365 |
my $query = $args->{QUERY}; |
366 |
$session->{logger}->info("[$session->{peer}] received search for '$query', (RS $args->{SETNAME})"); |
367 |
|
368 |
my ( $connection, $results, $num_hits ) = _start_search( $config, $session, $args ); |
369 |
return unless $connection; |
370 |
|
371 |
$args->{HITS} = $num_hits; |
372 |
my $resultset = $session->{resultsets}->{ $args->{SETNAME} } = { |
373 |
database => $database, |
374 |
connection => $connection, |
375 |
results => $results, |
376 |
query => $args->{QUERY}, |
377 |
hits => $args->{HITS}, |
378 |
}; |
379 |
} |
380 |
|
381 |
sub _check_fetch { |
382 |
my ( $args, $resultset, $offset, $num_records ) = @_; |
383 |
|
384 |
if ( !defined( $resultset ) ) { |
385 |
_set_error( $args, ERR_NO_SUCH_RESULTSET, 'No such resultset' ); |
386 |
return 0; |
387 |
} |
388 |
|
389 |
if ( $offset + $num_records > $resultset->{hits} ) { |
390 |
_set_error( $args, ERR_PRESENT_OUT_OF_RANGE, 'Fetch request out of range' ); |
391 |
return 0; |
392 |
} |
393 |
|
394 |
return 1; |
395 |
} |
396 |
|
397 |
sub present_handler { |
398 |
# Called when a set of records is requested. |
399 |
my ( $args ) = @_; |
400 |
my $session = $args->{HANDLE}; |
401 |
|
402 |
$session->{logger}->debug("[$session->{peer}] received present for $args->{SETNAME}, $args->{START}+$args->{NUMBER}"); |
403 |
|
404 |
my $resultset = $session->{resultsets}->{ $args->{SETNAME} }; |
405 |
# The offset comes across 1-indexed. |
406 |
my $offset = $args->{START} - 1; |
407 |
|
408 |
return unless _check_fetch( $args, $resultset, $offset, $args->{NUMBER} ); |
409 |
|
410 |
# Ignore if request is only for one record; our own prefetching will probably do a better job. |
411 |
_prefetch_records( $session, $resultset, $args, $offset, $args->{NUMBER} ) if ( $args->{NUMBER} > 1 ); |
412 |
} |
413 |
|
414 |
sub fetch_handler { |
415 |
# Called when a given record is requested. |
416 |
my ( $args ) = @_; |
417 |
my $config = $args->{GHANDLE}; |
418 |
my $session = $args->{HANDLE}; |
419 |
|
420 |
$session->{logger}->debug("[$session->{peer}] received fetch for $args->{SETNAME}, record $args->{OFFSET}"); |
421 |
my $form_oid = $args->{REQ_FORM} // ''; |
422 |
my $composition = $args->{COMP} // ''; |
423 |
$session->{logger}->debug("[$session->{peer}] form OID $form_oid, composition $composition"); |
424 |
|
425 |
my $resultset = $session->{resultsets}->{ $args->{SETNAME} }; |
426 |
# The offset comes across 1-indexed. |
427 |
my $offset = $args->{OFFSET} - 1; |
428 |
|
429 |
return unless _check_fetch( $args, $resultset, $offset, 1 ); |
430 |
|
431 |
$args->{LAST} = 1 if ( $offset == $resultset->{hits} - 1 ); |
432 |
|
433 |
my $record = _fetch_record( $session, $resultset, $args, $offset, $config->{num_to_prefetch} ); |
434 |
return unless $record; |
435 |
|
436 |
$record = C4::Search::new_record_from_zebra( |
437 |
$resultset->{database} eq 'biblios' ? 'biblioserver' : 'authorityserver', |
438 |
$record |
439 |
); |
440 |
|
441 |
if ( $config->{add_item_status_subfield} ) { |
442 |
my $tag = $config->{item_tag}; |
443 |
my $itemnumber_subfield = $config->{itemnumber_subfield}; |
444 |
my $add_subfield = $config->{add_item_status_subfield}; |
445 |
my $status_strings = $config->{status_strings}; |
446 |
|
447 |
foreach my $field ( $record->field($tag) ) { |
448 |
my $itemnumber = $field->subfield($itemnumber_subfield); |
449 |
next unless $itemnumber; |
450 |
|
451 |
my $item = GetItem( $itemnumber ); |
452 |
my @statuses; |
453 |
|
454 |
if ( $item->{onloan} ) { |
455 |
push @statuses, $status_strings->{CHECKED_OUT}; |
456 |
} |
457 |
|
458 |
if ( $item->{itemlost} ) { |
459 |
push @statuses, $status_strings->{LOST}; |
460 |
} |
461 |
|
462 |
if ( $item->{notforloan} ) { |
463 |
push @statuses, $status_strings->{NOT_FOR_LOAN}; |
464 |
} |
465 |
|
466 |
if ( $item->{damaged} ) { |
467 |
push @statuses, $status_strings->{DAMAGED}; |
468 |
} |
469 |
|
470 |
if ( $item->{withdrawn} ) { |
471 |
push @statuses, $status_strings->{WITHDRAWN}; |
472 |
} |
473 |
|
474 |
if ( scalar( GetTransfers( $itemnumber ) ) ) { |
475 |
push @statuses, $status_strings->{IN_TRANSIT}; |
476 |
} |
477 |
|
478 |
if ( GetReserveStatus( $itemnumber ) ne '' ) { |
479 |
push @statuses, $status_strings->{ON_HOLD}; |
480 |
} |
481 |
|
482 |
$field->delete_subfield( code => $itemnumber_subfield ); |
483 |
|
484 |
if ( $config->{add_status_multi_subfield} ) { |
485 |
$field->add_subfields( map { ( $add_subfield, $_ ) } ( @statuses ? @statuses : $status_strings->{AVAILABLE} ) ); |
486 |
} else { |
487 |
$field->add_subfields( $add_subfield, @statuses ? join( ', ', @statuses ) : $status_strings->{AVAILABLE} ); |
488 |
} |
489 |
} |
490 |
} |
491 |
|
492 |
if ( $form_oid eq MARCXML_OID && $composition eq 'marcxml' ) { |
493 |
$args->{RECORD} = $record->as_xml_record(); |
494 |
} elsif ( ( $form_oid eq USMARC_OID || $form_oid eq UNIMARC_OID ) && ( !$composition || $composition eq 'F' ) ) { |
495 |
$args->{RECORD} = $record->as_usmarc(); |
496 |
} else { |
497 |
_set_error( $args, ERR_SYNTAX_UNSUPPORTED, "Unsupported syntax/composition $form_oid/$composition" ); |
498 |
return; |
499 |
} |
500 |
} |
501 |
|
502 |
sub close_handler { |
503 |
my ( $args ) = @_; |
504 |
|
505 |
my $session = $args->{HANDLE}; |
506 |
|
507 |
foreach my $resultset ( values %{ $session->{resultsets} } ) { |
508 |
_close_resultset( $resultset ); |
509 |
} |
510 |
} |