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 / +482 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 [-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
}

Return to bug 13937