View | Details | Raw Unified | Return to bug 13937
Collapse All | Expand All

(-)a/C4/Installer/PerlDependencies.pm (+5 lines)
Lines 782-787 our $PERL_DEPS = { Link Here
782
        'required' => '1',
782
        'required' => '1',
783
        'min_ver'  => '1.10',
783
        'min_ver'  => '1.10',
784
    },
784
    },
785
    'Net::Z3950::SimpleServer' => {
786
        'usage'    => 'Z39.50 responder',
787
        'required' => '0',
788
        'min_ver'  => '1.15',
789
    },
785
};
790
};
786
791
787
1;
792
1;
(-)a/Koha/Logger.pm (+24 lines)
Lines 177-182 sub _recheck_logfile { # recheck saved logfile when logging message Link Here
177
    return -w $log;
177
    return -w $log;
178
}
178
}
179
179
180
=head2 debug_to_screen
181
182
Adds a new appender for the given logger that will log all DEBUG-and-higher messages to stderr.
183
Useful for daemons.
184
185
=cut
186
187
sub debug_to_screen {
188
    my $self = shift;
189
190
    return unless ( $self->{logger} );
191
192
    my $appender = Log::Log4perl::Appender->new(
193
        'Log::Log4perl::Appender::Screen',
194
        stderr => 1,
195
        utf8 => 1,
196
        name => 'debug_to_screen' # We need a specific name to prevent duplicates
197
    );
198
199
    $appender->threshold( $Log::Log4perl::DEBUG );
200
    $self->{logger}->add_appender( $appender );
201
    $self->{logger}->level( $Log::Log4perl::DEBUG );
202
}
203
180
=head1 AUTHOR
204
=head1 AUTHOR
181
205
182
Kyle M Hall, E<lt>kyle@bywatersolutions.comE<gt>
206
Kyle M Hall, E<lt>kyle@bywatersolutions.comE<gt>
(-)a/etc/log4perl.conf (+7 lines)
Lines 11-13 log4perl.appender.OPAC.filename=__LOG_DIR__/opac-error.log Link Here
11
log4perl.appender.OPAC.mode=append
11
log4perl.appender.OPAC.mode=append
12
log4perl.appender.OPAC.layout=PatternLayout
12
log4perl.appender.OPAC.layout=PatternLayout
13
log4perl.appender.OPAC.layout.ConversionPattern=[%d] [%p] %m %l %n
13
log4perl.appender.OPAC.layout.ConversionPattern=[%d] [%p] %m %l %n
14
15
log4perl.logger.z3950 = WARN, Z3950
16
log4perl.appender.Z3950=Log::Log4perl::Appender::File
17
log4perl.appender.Z3950.filename=__LOG_DIR__/logs/z3950-error.log
18
log4perl.appender.Z3950.mode=append
19
log4perl.appender.Z3950.layout=PatternLayout
20
log4perl.appender.Z3950.layout.ConversionPattern=[%d] [%p] %m %l %n
(-)a/misc/z3950_responder.pl (-1 / +510 lines)
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
}

Return to bug 13937