adding openncip / opensip SIP2 service
Signed-off-by: Chris Cormack <crc@liblime.com> Signed-off-by: Joshua Ferraro <jmf@liblime.com>
This commit is contained in:
Ryan Higgins
Joshua Ferraro
parent
fa99edd8b3
commit
7b9b36bd2e
|
|
@ -0,0 +1,498 @@
|
|||
#
|
||||
# ILS.pm: Test ILS interface module
|
||||
#
|
||||
|
||||
package ILS;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
use Sys::Syslog qw(syslog);
|
||||
|
||||
use ILS::Item;
|
||||
use ILS::Patron;
|
||||
use ILS::Transaction;
|
||||
use ILS::Transaction::Checkout;
|
||||
use ILS::Transaction::Checkin;
|
||||
use ILS::Transaction::FeePayment;
|
||||
use ILS::Transaction::Hold;
|
||||
use ILS::Transaction::Renew;
|
||||
use ILS::Transaction::RenewAll;
|
||||
|
||||
my %supports = (
|
||||
'magnetic media' => 0,
|
||||
'security inhibit' => 0,
|
||||
'offline operation' => 0,
|
||||
"patron status request" => 1,
|
||||
"checkout" => 1,
|
||||
"checkin" => 1,
|
||||
"block patron" => 1,
|
||||
"acs status" => 1,
|
||||
"login" => 1,
|
||||
"patron information" => 1,
|
||||
"end patron session" => 1,
|
||||
"fee paid" => 0,
|
||||
"item information" => 1,
|
||||
"item status update" => 0,
|
||||
"patron enable" => 1,
|
||||
"hold" => 1,
|
||||
"renew" => 1,
|
||||
"renew all" => 0,
|
||||
);
|
||||
|
||||
sub new {
|
||||
my ($class, $institution) = @_;
|
||||
my $type = ref($class) || $class;
|
||||
my $self = {};
|
||||
|
||||
syslog("LOG_DEBUG", "new ILS '%s'", $institution->{id});
|
||||
$self->{institution} = $institution;
|
||||
|
||||
return bless $self, $type;
|
||||
}
|
||||
|
||||
sub find_patron {
|
||||
my $self = shift;
|
||||
|
||||
return ILS::Patron->new(@_);
|
||||
}
|
||||
|
||||
sub find_item {
|
||||
my $self = shift;
|
||||
|
||||
return ILS::Item->new(@_);
|
||||
}
|
||||
|
||||
sub institution {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{institution}->{id};
|
||||
}
|
||||
|
||||
sub supports {
|
||||
my ($self, $op) = @_;
|
||||
|
||||
return (exists($supports{$op}) && $supports{$op});
|
||||
}
|
||||
|
||||
sub check_inst_id {
|
||||
my ($self, $id, $whence) = @_;
|
||||
|
||||
if ($id ne $self->{institution}->{id}) {
|
||||
syslog("LOG_WARNING", "%s: received institution '%s', expected '%s'",
|
||||
$whence, $id, $self->{institution}->{id});
|
||||
}
|
||||
}
|
||||
|
||||
sub to_bool {
|
||||
my $bool = shift;
|
||||
|
||||
# If it's defined, and matches a true sort of string, or is
|
||||
# a non-zero number, then it's true.
|
||||
return defined($bool) && (($bool =~ /true|y|yes/i) || $bool != 0);
|
||||
}
|
||||
|
||||
sub checkout_ok {
|
||||
my $self = shift;
|
||||
|
||||
return (exists($self->{policy}->{checkout})
|
||||
&& to_bool($self->{policy}->{checkout}));
|
||||
}
|
||||
|
||||
sub checkin_ok {
|
||||
my $self = shift;
|
||||
|
||||
return (exists($self->{policy}->{checkin})
|
||||
&& to_bool($self->{policy}->{checkin}));
|
||||
}
|
||||
|
||||
sub status_update_ok {
|
||||
my $self = shift;
|
||||
|
||||
return (exists($self->{policy}->{status_update})
|
||||
&& to_bool($self->{policy}->{status_update}));
|
||||
|
||||
}
|
||||
|
||||
sub offline_ok {
|
||||
my $self = shift;
|
||||
|
||||
return (exists($self->{policy}->{offline})
|
||||
&& to_bool($self->{policy}->{offline}));
|
||||
}
|
||||
|
||||
#
|
||||
# Checkout(patron_id, item_id, sc_renew):
|
||||
# patron_id & item_id are the identifiers send by the terminal
|
||||
# sc_renew is the renewal policy configured on the terminal
|
||||
# returns a status opject that can be queried for the various bits
|
||||
# of information that the protocol (SIP or NCIP) needs to generate
|
||||
# the response.
|
||||
#
|
||||
sub checkout {
|
||||
my ($self, $patron_id, $item_id, $sc_renew) = @_;
|
||||
my ($patron, $item, $circ);
|
||||
|
||||
$circ = new ILS::Transaction::Checkout;
|
||||
|
||||
# BEGIN TRANSACTION
|
||||
$circ->patron($patron = new ILS::Patron $patron_id);
|
||||
$circ->item($item = new ILS::Item $item_id);
|
||||
|
||||
if (!$patron) {
|
||||
$circ->screen_msg("Invalid Patron");
|
||||
} elsif (!$patron->charge_ok) {
|
||||
$circ->screen_msg("Patron Blocked");
|
||||
} elsif (!$item) {
|
||||
$circ->screen_msg("Invalid Item");
|
||||
} elsif (@{$item->hold_queue} && ($patron_id ne $item->hold_queue->[0])) {
|
||||
$circ->screen_msg("Item on Hold for Another User");
|
||||
} elsif ($item->{patron} && ($item->{patron} ne $patron_id)) {
|
||||
# I can't deal with this right now
|
||||
$circ->screen_msg("Item checked out to another patron");
|
||||
} else {
|
||||
$circ->ok(1);
|
||||
# If the item is already associated with this patron, then
|
||||
# we're renewing it.
|
||||
$circ->renew_ok($item->{patron} && ($item->{patron} eq $patron_id));
|
||||
$item->{patron} = $patron_id;
|
||||
$item->{due_date} = time + (14*24*60*60); # two weeks
|
||||
push(@{$patron->{items}}, $item_id);
|
||||
$circ->desensitize(!$item->magnetic);
|
||||
|
||||
syslog("LOG_DEBUG", "ILS::Checkout: patron %s has checked out %s",
|
||||
$patron_id, join(', ', @{$patron->{items}}));
|
||||
}
|
||||
|
||||
# END TRANSACTION
|
||||
|
||||
return $circ;
|
||||
}
|
||||
|
||||
sub checkin {
|
||||
my ($self, $item_id, $trans_date, $return_date,
|
||||
$current_loc, $item_props, $cancel) = @_;
|
||||
my ($patron, $item, $circ);
|
||||
|
||||
$circ = new ILS::Transaction::Checkin;
|
||||
# BEGIN TRANSACTION
|
||||
$circ->item($item = new ILS::Item $item_id);
|
||||
|
||||
# It's ok to check it in if it exists, and if it was checked out
|
||||
$circ->ok($item && $item->{patron});
|
||||
|
||||
if ($circ->ok) {
|
||||
$circ->patron($patron = new ILS::Patron $item->{patron});
|
||||
delete $item->{patron};
|
||||
delete $item->{due_date};
|
||||
$patron->{items} = [ grep {$_ ne $item_id} @{$patron->{items}} ];
|
||||
}
|
||||
# END TRANSACTION
|
||||
|
||||
return $circ;
|
||||
}
|
||||
|
||||
# If the ILS caches patron information, this lets it free
|
||||
# it up
|
||||
sub end_patron_session {
|
||||
my ($self, $patron_id) = @_;
|
||||
|
||||
# success?, screen_msg, print_line
|
||||
return (1, 'Thank you for using Evergreen!', '');
|
||||
}
|
||||
|
||||
sub pay_fee {
|
||||
my ($self, $patron_id, $patron_pwd, $fee_amt, $fee_type,
|
||||
$pay_type, $fee_id, $trans_id, $currency) = @_;
|
||||
my $trans;
|
||||
my $patron;
|
||||
|
||||
$trans = new ILS::Transaction::FeePayment;
|
||||
|
||||
$patron = new ILS::Patron $patron_id;
|
||||
|
||||
$trans->transaction_id($trans_id);
|
||||
$trans->patron($patron);
|
||||
$trans->ok(1);
|
||||
|
||||
return $trans;
|
||||
}
|
||||
|
||||
sub add_hold {
|
||||
my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
|
||||
$expiry_date, $pickup_location, $hold_type, $fee_ack) = @_;
|
||||
my ($patron, $item);
|
||||
my $hold;
|
||||
my $trans;
|
||||
|
||||
|
||||
$trans = new ILS::Transaction::Hold;
|
||||
|
||||
# BEGIN TRANSACTION
|
||||
$patron = new ILS::Patron $patron_id;
|
||||
if (!$patron
|
||||
|| (defined($patron_pwd) && !$patron->check_password($patron_pwd))) {
|
||||
$trans->screen_msg("Invalid Patron.");
|
||||
|
||||
return $trans;
|
||||
}
|
||||
|
||||
$item = new ILS::Item ($item_id || $title_id);
|
||||
if (!$item) {
|
||||
$trans->screen_msg("No such item.");
|
||||
|
||||
# END TRANSACTION (conditionally)
|
||||
return $trans;
|
||||
} elsif ($item->fee && ($fee_ack ne 'Y')) {
|
||||
$trans->screen_msg = "Fee required to place hold.";
|
||||
|
||||
# END TRANSACTION (conditionally)
|
||||
return $trans;
|
||||
}
|
||||
|
||||
$hold = {
|
||||
item_id => $item->id,
|
||||
patron_id => $patron->id,
|
||||
expiration_date => $expiry_date,
|
||||
pickup_location => $pickup_location,
|
||||
hold_type => $hold_type,
|
||||
};
|
||||
|
||||
$trans->ok(1);
|
||||
$trans->patron($patron);
|
||||
$trans->item($item);
|
||||
$trans->pickup_location($pickup_location);
|
||||
|
||||
push(@{$item->hold_queue}, $hold);
|
||||
push(@{$patron->{hold_items}}, $hold);
|
||||
|
||||
|
||||
# END TRANSACTION
|
||||
return $trans;
|
||||
}
|
||||
|
||||
sub cancel_hold {
|
||||
my ($self, $patron_id, $patron_pwd, $item_id, $title_id) = @_;
|
||||
my ($patron, $item, $hold);
|
||||
my $trans;
|
||||
|
||||
$trans = new ILS::Transaction::Hold;
|
||||
|
||||
# BEGIN TRANSACTION
|
||||
$patron = new ILS::Patron $patron_id;
|
||||
if (!$patron) {
|
||||
$trans->screen_msg("Invalid patron barcode.");
|
||||
|
||||
return $trans;
|
||||
} elsif (defined($patron_pwd) && !$patron->check_password($patron_pwd)) {
|
||||
$trans->screen_msg('Invalid patron password.');
|
||||
|
||||
return $trans;
|
||||
}
|
||||
|
||||
$item = new ILS::Item ($item_id || $title_id);
|
||||
if (!$item) {
|
||||
$trans->screen_msg("No such item.");
|
||||
|
||||
# END TRANSACTION (conditionally)
|
||||
return $trans;
|
||||
}
|
||||
|
||||
# Remove the hold from the patron's record first
|
||||
$trans->ok($patron->drop_hold($item_id));
|
||||
|
||||
if (!$trans->ok) {
|
||||
# We didn't find it on the patron record
|
||||
$trans->screen_msg("No such hold on patron record.");
|
||||
|
||||
# END TRANSACTION (conditionally)
|
||||
return $trans;
|
||||
}
|
||||
|
||||
# Now, remove it from the item record. If it was on the patron
|
||||
# record but not on the item record, we'll treat that as success.
|
||||
foreach my $i (0 .. scalar @{$item->hold_queue}) {
|
||||
$hold = $item->hold_queue->[$i];
|
||||
|
||||
if ($hold->{patron_id} eq $patron->id) {
|
||||
# found it: delete it.
|
||||
splice @{$item->hold_queue}, $i, 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
$trans->screen_msg("Hold Cancelled.");
|
||||
$trans->patron($patron);
|
||||
$trans->item($item);
|
||||
|
||||
return $trans;
|
||||
}
|
||||
|
||||
|
||||
# The patron and item id's can't be altered, but the
|
||||
# date, location, and type can.
|
||||
sub alter_hold {
|
||||
my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
|
||||
$expiry_date, $pickup_location, $hold_type, $fee_ack) = @_;
|
||||
my ($patron, $item);
|
||||
my $hold;
|
||||
my $trans;
|
||||
|
||||
$trans = new ILS::Transaction::Hold;
|
||||
|
||||
# BEGIN TRANSACTION
|
||||
$patron = new ILS::Patron $patron_id;
|
||||
if (!$patron) {
|
||||
$trans->screen_msg("Invalid patron barcode.");
|
||||
|
||||
return $trans;
|
||||
}
|
||||
|
||||
foreach my $i (0 .. scalar @{$patron->{hold_items}}) {
|
||||
$hold = $patron->{hold_items}[$i];
|
||||
|
||||
if ($hold->{item_id} eq $item_id) {
|
||||
# Found it. So fix it.
|
||||
$hold->{expiration_date} = $expiry_date if $expiry_date;
|
||||
$hold->{pickup_location} = $pickup_location if $pickup_location;
|
||||
$hold->{hold_type} = $hold_type if $hold_type;
|
||||
|
||||
$trans->ok(1);
|
||||
$trans->screen_msg("Hold updated.");
|
||||
$trans->patron($patron);
|
||||
$trans->item(new ILS::Item $hold->{item_id});
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
# The same hold structure is linked into both the patron's
|
||||
# list of hold items and into the queue of outstanding holds
|
||||
# for the item, so we don't need to search the hold queue for
|
||||
# the item, since it's already been updated by the patron code.
|
||||
|
||||
if (!$trans->ok) {
|
||||
$trans->screen_msg("No such outstanding hold.");
|
||||
}
|
||||
|
||||
return $trans;
|
||||
}
|
||||
|
||||
sub renew {
|
||||
my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
|
||||
$no_block, $nb_due_date, $third_party,
|
||||
$item_props, $fee_ack) = @_;
|
||||
my ($patron, $item);
|
||||
my $trans;
|
||||
|
||||
$trans = new ILS::Transaction::Renew;
|
||||
|
||||
$trans->patron($patron = new ILS::Patron $patron_id);
|
||||
|
||||
if (!$patron) {
|
||||
$trans->screen_msg("Invalid patron barcode.");
|
||||
|
||||
return $trans;
|
||||
} elsif (!$patron->renew_ok) {
|
||||
$trans->screen_msg("Renewals not allowed.");
|
||||
|
||||
return $trans;
|
||||
}
|
||||
|
||||
if (defined($title_id)) {
|
||||
# renewing a title, rather than an item (sort of)
|
||||
# This is gross, but in a real ILS it would be better
|
||||
foreach my $i (@{$patron->{items}}) {
|
||||
$item = new ILS::Item $i;
|
||||
last if ($title_id eq $item->title_id);
|
||||
$item = undef;
|
||||
}
|
||||
} else {
|
||||
foreach my $i (@{$patron->{items}}) {
|
||||
if ($i == $item_id) {
|
||||
# We have it checked out
|
||||
$item = new ILS::Item $item_id;
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$trans->item($item);
|
||||
|
||||
if (!defined($item)) {
|
||||
# It's not checked out to $patron_id
|
||||
$trans->screen_msg("Item not checked out to " . $patron->name);
|
||||
} elsif (!$item->available($patron_id)) {
|
||||
$trans->screen_msg("Item has outstanding holds");
|
||||
} else {
|
||||
$trans->renewal_ok(1);
|
||||
|
||||
$trans->desensitize(0); # It's already checked out
|
||||
|
||||
if ($no_block eq 'Y') {
|
||||
$item->{due_date} = $nb_due_date;
|
||||
} else {
|
||||
$item->{due_date} = time + (14*24*60*60); # two weeks
|
||||
}
|
||||
if ($item_props) {
|
||||
$item->{sip_item_properties} = $item_props;
|
||||
}
|
||||
$trans->ok(1);
|
||||
$trans->renewal_ok(1);
|
||||
|
||||
return $trans;
|
||||
}
|
||||
|
||||
return $trans;
|
||||
}
|
||||
|
||||
sub renew_all {
|
||||
my ($self, $patron_id, $patron_pwd, $fee_ack) = @_;
|
||||
my ($patron, $item_id);
|
||||
my $trans;
|
||||
|
||||
$trans = new ILS::Transaction::RenewAll;
|
||||
|
||||
$trans->patron($patron = new ILS::Patron $patron_id);
|
||||
if (defined $patron) {
|
||||
syslog("LOG_DEBUG", "ILS::renew_all: patron '%s': renew_ok: %s",
|
||||
$patron->name, $patron->renew_ok);
|
||||
} else {
|
||||
syslog("LOG_DEBUG", "ILS::renew_all: Invalid patron id: '%s'",
|
||||
$patron_id);
|
||||
}
|
||||
|
||||
if (!defined($patron)) {
|
||||
$trans->screen_msg("Invalid patron barcode.");
|
||||
return $trans;
|
||||
} elsif (!$patron->renew_ok) {
|
||||
$trans->screen_msg("Renewals not allowed.");
|
||||
return $trans;
|
||||
} elsif (defined($patron_pwd) && !$patron->check_password($patron_pwd)) {
|
||||
$trans->screen_msg("Invalid patron password.");
|
||||
return $trans;
|
||||
}
|
||||
|
||||
foreach $item_id (@{$patron->{items}}) {
|
||||
my $item = new ILS::Item $item_id;
|
||||
|
||||
if (!defined($item)) {
|
||||
syslog("LOG_WARNING",
|
||||
"renew_all: Invalid item id associated with patron '%s'",
|
||||
$patron->id);
|
||||
next;
|
||||
}
|
||||
|
||||
if (@{$item->hold_queue}) {
|
||||
# Can't renew if there are outstanding holds
|
||||
push @{$trans->unrenewed}, $item_id;
|
||||
} else {
|
||||
$item->{due_date} = time + (14*24*60*60); # two weeks hence
|
||||
push @{$trans->renewed}, $item_id;
|
||||
}
|
||||
}
|
||||
|
||||
$trans->ok(1);
|
||||
|
||||
return $trans;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,486 @@
|
|||
=head1 NAME
|
||||
|
||||
ILS - Portability layer to interface between Open-SIP and ILS
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use ILS;
|
||||
|
||||
# Initialize connection between SIP and the ILS
|
||||
my $ils = new ILS (institution => 'Foo Public Library');
|
||||
|
||||
# Basic object access methods
|
||||
$inst_name = $self->institution;
|
||||
$bool = $self->support($operation);
|
||||
$self->check_inst_id($inst_name, "error message");
|
||||
|
||||
# Check to see if certain protocol options are permitted
|
||||
$bool = $self->checkout_ok;
|
||||
$bool = $self->checkin_ok;
|
||||
$bool = $self->status_update_ok;
|
||||
$bool = $self->offline_ok;
|
||||
|
||||
$status = $ils->checkout($patron_id, $item_id, $sc_renew);
|
||||
|
||||
$status = $ils->checkin($item_id, $trans_date, $return_date,
|
||||
$current_loc, $item_props, $cancel);
|
||||
|
||||
$status = $ils->end_patron_session($patron_id);
|
||||
|
||||
$status = $ils->pay_fee($patron_id, $patron_pwd, $fee_amt,
|
||||
$fee_type, $pay_type, $fee_id, $trans_id,
|
||||
$currency);
|
||||
|
||||
$status = $ils->add_hold($patron_id, $patron_pwd, $item_id,
|
||||
$title_id, $expiry_date,
|
||||
$pickup_locn, $hold_type, $fee_ack);
|
||||
|
||||
$status = $ils->cancel_hold($patron_id, $patron_pwd,
|
||||
$item_id, $title_id);
|
||||
|
||||
$status = $ils->alter_hold($patron_id, $patron_pwd, $item_id,
|
||||
$title_id, $expiry_date,
|
||||
$pickup_locn, $hold_type,
|
||||
$fee_ack);
|
||||
|
||||
$status = $ils->renew($patron_id, $patron_pwd, $item_id,
|
||||
$title_id, $no_block, $nb_due_date,
|
||||
$third_party, $item_props, $fee_ack);
|
||||
|
||||
$status = $ils->renew_all($patron_id, $patron_pwd, $fee_ack);
|
||||
|
||||
=head1 INTRODUCTION
|
||||
|
||||
The ILS module defines a basic portability layer between the SIP
|
||||
server and the rest of the integrated library system. It is the
|
||||
responsibility of the ILS vendor to implement the functions
|
||||
defined by this interface. This allows the SIP server to be
|
||||
reasonably portable between ILS systems (of course, we won't know
|
||||
exactly I<how> portable the interface is until it's been used by
|
||||
a second ILS.
|
||||
|
||||
Because no business logic is embedded in the SIP server code
|
||||
itself, the SIP protocol handler functions do almost nothing
|
||||
except decode the network messages and pass the parameters to the
|
||||
ILS module or one of its submodules, C<ILS::Patron> and
|
||||
C<ILS::Item>. The SIP protocol query messages (Patron
|
||||
Information, or Item Status, for example), are implemented within
|
||||
the SIP server code by fetching a Patron, or Item, record and
|
||||
then retrieving the relevant information from that record. See
|
||||
L<ILS::Patron> and L<ILS::Item> for the details.
|
||||
|
||||
=head1 INITIALIZATION
|
||||
|
||||
The first thing the SIP server does, after a terminal has
|
||||
successfully logged in, is initialize the ILS module by calling
|
||||
|
||||
$ils = new ILS $institution
|
||||
|
||||
where C<$institution> is an object of type
|
||||
C<Sip::Configuration::Institution>, describing the institution to
|
||||
which the terminal belongs. In general, this will be the single
|
||||
institution that the ILS supports, but it may be that in a
|
||||
consortial setting, the SIP server may support connecting to
|
||||
different ILSs based on the C<$institution> of the terminal.
|
||||
|
||||
=head1 BASIC OBJECT ACCESS AND PROTOCOL SUPPORT
|
||||
|
||||
The C<$ils> object supports a small set of simple access methods
|
||||
and methods that allow the SIP server to determine if certain
|
||||
protocol operations are permitted to the remote terminals.
|
||||
|
||||
=head2 C<$inst_name = $self-E<gt>institution;>
|
||||
|
||||
Returns the institution ID as a string, suitable for
|
||||
incorporating into a SIP response message.
|
||||
|
||||
=head2 C<$bool = $self-E<gt>support($operation);>
|
||||
|
||||
Reports whether this ILS implementation supports certain
|
||||
operations that are necessary to report information to the SIP
|
||||
terminal. The argument C<$operation> is a string from this list:
|
||||
|
||||
=over
|
||||
|
||||
=item C<'magnetic media'>
|
||||
|
||||
Can the ILS properly report whether an item is (or contains)
|
||||
magnetic media, such as a videotape or a book with a floppy disk?
|
||||
|
||||
=item C<'security inhibit'>
|
||||
|
||||
Is the ILS capable of directing the terminal to ignore the
|
||||
security status of an item?
|
||||
|
||||
=item C<'offline operation'>
|
||||
|
||||
Does the ILS allow self-check units to operate when unconnected
|
||||
to the ILS? That is, can a self-check unit check out items to
|
||||
patrons without checking the status of the items and patrons in
|
||||
real time?
|
||||
|
||||
=back
|
||||
|
||||
=head2 C<$bool = $self-E<gt>checkout_ok;>
|
||||
|
||||
Are the self service terminals permitted to check items out to
|
||||
patrons?
|
||||
|
||||
=head2 C<$bool = $self-E<gt>checkin_ok;>
|
||||
|
||||
Are the self service terminals permitted to check items in?
|
||||
|
||||
=head2 C<$bool = $self-E<gt>status_update_ok;>
|
||||
|
||||
Are the self service terminals permitted to update patron status
|
||||
information. For example, can terminals block patrons?
|
||||
|
||||
=head2 C<$bool = $self-E<gt>offline_ok>;
|
||||
|
||||
Are the self service terminals permitted to operate off-line.
|
||||
That is, can they perform their core self service operations when
|
||||
not in communication with the ILS?
|
||||
|
||||
=head1 THE TRANSACTIONS
|
||||
|
||||
In general, every protocol transaction that changes the status of
|
||||
some ILS object (Patron or Item) has a corresponding C<ILS>
|
||||
method. Operations like C<Check In>, which are a function of
|
||||
both a patron and an item are C<ILS> functions, while others,
|
||||
like C<Patron Status> or C<Item Status>, which only depend on one
|
||||
type of object, are methods of the corresponding sub-module.
|
||||
|
||||
In the stub implementation provided with the SIP system, the
|
||||
C<$status> objects returned by the various C<ILS> transactions
|
||||
are objects that are subclasses of a virtual C<ILS::Transaction>
|
||||
object, but this is not required of the SIP code, as long as the
|
||||
status objects support the appropriate methods.
|
||||
|
||||
=head2 CORE TRANSACTION STATUS METHODS
|
||||
|
||||
The C<$status> objects returned by all transactions must support
|
||||
the following common methods:
|
||||
|
||||
=over
|
||||
|
||||
=item C<ok>
|
||||
|
||||
Returns C<true> if the transaction was successful and C<false> if
|
||||
not. Other methods can be used to find out what went wrong.
|
||||
|
||||
=item C<item>
|
||||
|
||||
Returns an C<ILS::Item> object corresponding to the item with the
|
||||
barcode C<$item_id>, or C<undef> if the barcode is invalid.
|
||||
|
||||
=item C<patron>
|
||||
|
||||
Returns a C<ILS::Patron> object corresponding to the patron with
|
||||
the barcode C<$patron_id>, or C<undef> if the barcode is invalid
|
||||
(ie, nonexistent, as opposed to "expired" or "delinquent").
|
||||
|
||||
=item C<screen_msg>
|
||||
|
||||
Optional. Returns a message that is to be displayed on the
|
||||
terminal's screen. Some self service terminals read the value of
|
||||
this string and act based on it. The configuration of the
|
||||
terminal, and the ILS implementation of this method will have to
|
||||
be coordinated.
|
||||
|
||||
=item C<print_line>
|
||||
|
||||
Optional. Returns a message that is to be printed on the
|
||||
terminal's receipt printer. This message is distinct from the
|
||||
basic transactional information that the terminal will be
|
||||
printing anyway (such as, the basic checkout information like the
|
||||
title and due date).
|
||||
|
||||
=back
|
||||
|
||||
=head2 C<$status = $ils-E<gt>checkout($patron_id, $item_id, $sc_renew)>
|
||||
|
||||
Check out (or possibly renew) item with barcode C<$item_id> to
|
||||
the patron with barcode C<$patron_id>. If C<$sc_renew> is true,
|
||||
then the self-check terminal has been configured to allow
|
||||
self-renewal of items, and the ILS may take this into account
|
||||
when deciding how to handle the case where C<$item_id> is already
|
||||
checked out to C<$patron_id>.
|
||||
|
||||
The C<$status> object returned by C<checkout> must support the
|
||||
following methods:
|
||||
|
||||
=over
|
||||
|
||||
=item C<renewal_ok>
|
||||
|
||||
Is this transaction actually a renewal? That is, did C<$patron_id>
|
||||
already have C<$item_id> checked out?
|
||||
|
||||
=item C<desensitize>
|
||||
|
||||
Should the terminal desensitize the item? This will be false for
|
||||
magnetic media, like videocassettes, and for "in library" items
|
||||
that are checked out to the patron, but not permitted to leave the
|
||||
building.
|
||||
|
||||
=item C<security_inhibit>
|
||||
|
||||
Should self checkout unit ignore the security status of this
|
||||
item?
|
||||
|
||||
This method will only be used if
|
||||
|
||||
$ils->supports('security inhibit')
|
||||
|
||||
returns C<true>.
|
||||
|
||||
=item C<fee_amount>
|
||||
|
||||
If there is a fee associated with the use of C<$item_id>, then
|
||||
this method should return the amount of the fee, otherwise it
|
||||
should return zero. See also the C<sip_currency> and
|
||||
C<sip_fee_type> methods.
|
||||
|
||||
=item C<sip_currency>
|
||||
|
||||
The ISO currency code for the currency in which the fee
|
||||
associated with this item is denominated. For example, 'USD' or
|
||||
'CAD'.
|
||||
|
||||
=item C<sip_fee_type>
|
||||
|
||||
A code indicating the type of fee associated with this item. See
|
||||
the table in the protocol specification for the complete list of
|
||||
standard values that this function can return.
|
||||
|
||||
=back
|
||||
|
||||
=head2 C<$status = $ils-E<gt>checkin($item_id, $trans_date, $return_date, $current_loc, $item_props, $cancel)>
|
||||
|
||||
Check in item identified by barcode C<$item_id>. This
|
||||
transaction took place at time C<$trans_date> and was effective
|
||||
C<$return_date> (to allow for backdating of items to when the
|
||||
branch closed, for example). The self check unit which received
|
||||
the item is located at C<$current_loc>, and the item has
|
||||
properties C<$item_props>. The parameters C<$current_loc> and
|
||||
C<$item_props> are opaque strings passed from the self service
|
||||
unit to the ILS untranslated. The configuration of the terminal,
|
||||
and the ILS implementation of this method will have to be
|
||||
coordinated.
|
||||
|
||||
The C<$status> object returned by the C<checkin> operation must
|
||||
support the following methods:
|
||||
|
||||
=over
|
||||
|
||||
=item C<resensitize>
|
||||
|
||||
Does the item need to be resensitized by the self check unit?
|
||||
|
||||
=item C<alert>
|
||||
|
||||
Should the self check unit generate an audible alert to notify
|
||||
staff that the item has been returned?
|
||||
|
||||
=item C<sort_bin>
|
||||
|
||||
Certain self checkin units provide for automated sorting of the
|
||||
returned items. This function returns the bin number into which
|
||||
the received item should be placed. This function may return the
|
||||
empty string, or C<undef>, to indicate that no sort bin has been
|
||||
specified.
|
||||
|
||||
=back
|
||||
|
||||
=head2 C<($status, $screen_msg, $print_line) = $ils-E<gt>end_patron_session($patron_id)>
|
||||
|
||||
This function informs the ILS that the current patron's session
|
||||
has ended. This allows the ILS to free up any internal state
|
||||
that it may be preserving between messages from the self check
|
||||
unit. The function returns a boolean C<$status>, where C<true>
|
||||
indicates success, and two strings: a screen message to display
|
||||
on the self check unit's console, and a print line to be printed
|
||||
on the unit's receipt printer.
|
||||
|
||||
=head2 C<$status = $ils-E<gt>pay_fee($patron_id, $patron_pwd, $fee_amt, $fee_type, $pay_type, $fee_id, $trans_id, $currency)>
|
||||
|
||||
Reports that the self check terminal handled fee payment from
|
||||
patron C<$patron_id> (who has password C<$patron_pwd>, which is
|
||||
an optional parameter). The other parameters are:
|
||||
|
||||
=over
|
||||
|
||||
=item C<$fee_amt>
|
||||
|
||||
The amount of the fee.
|
||||
|
||||
=item C<$fee_type>
|
||||
|
||||
The type of fee, according a table in the SIP protocol
|
||||
specification.
|
||||
|
||||
=item C<$pay_type>
|
||||
|
||||
The payment method. Defined in the SIP protocol specification.
|
||||
|
||||
=item C<$fee_id>
|
||||
|
||||
Optional. Identifies which particular fee was paid. This
|
||||
identifier would have been sent from the ILS to the Self Check
|
||||
unit by a previous "Patron Information Response" message.
|
||||
|
||||
=item C<$trans_id>
|
||||
|
||||
Optional. A transaction identifier set by the payment device.
|
||||
This should be recorded by the ILS for financial tracking
|
||||
purposes.
|
||||
|
||||
=item C<$currency>
|
||||
|
||||
An ISO currency code indicating the currency in which the fee was
|
||||
paid.
|
||||
|
||||
=back
|
||||
|
||||
The status object returned by the C<pay_fee> must support the
|
||||
following methods:
|
||||
|
||||
=over
|
||||
|
||||
=item C<transaction_id>
|
||||
|
||||
Transaction identifier of the transaction. This parallels the
|
||||
optional C<$trans_id> sent from the terminal to the ILS. This
|
||||
may return an empty string.
|
||||
|
||||
=back
|
||||
|
||||
=head2 C<$status = $ils-E<gt>add_hold($patron_id, $patron_pwd, $item_id, $title_id, $expiry_date, $pickup_locn, $hold_type, $fee_ack);>
|
||||
|
||||
Places a hold for C<$patron_id> (optionally, with password
|
||||
C<$patron_pwd>) on the item described by either C<$item_id> or
|
||||
C<$title_id>. The other parameters are:
|
||||
|
||||
=over
|
||||
|
||||
=item C<$expiry_date>
|
||||
|
||||
The date on which the hold should be cancelled. This date is a
|
||||
SIP protocol standard format timestamp:
|
||||
|
||||
YYYYMMDDZZZZHHMMSS
|
||||
|
||||
where the 'Z' characters indicate spaces.
|
||||
|
||||
=item C<$pickup_location>
|
||||
|
||||
The location at which the patron wishes to pick up the item when
|
||||
it's available. The configuration of the terminal, and the ILS
|
||||
implementation of this parameter will have to be coordinated.
|
||||
|
||||
=item C<$hold_type>
|
||||
|
||||
The type of hold being placed: any copy, a specific copy, any
|
||||
copy from a particular branch or location. See the SIP protocol
|
||||
specification for the exact values that this parameter might
|
||||
take.
|
||||
|
||||
=item C<$fee_ack>
|
||||
|
||||
Boolean. If true, the patron has acknowleged that she is willing
|
||||
to pay the fee associated with placing a hold on this item. If
|
||||
C<$fee_ack> is false, then the ILS should refuse to place the
|
||||
hold.
|
||||
|
||||
=back
|
||||
|
||||
=head2 C<$status = $ils-E<gt>cancel_hold($patron_id, $patron_pwd, $item_id, $title_id);>
|
||||
|
||||
Cancel a hold placed by C<$patron_id> for the item identified by
|
||||
C<$item_id> or C<$title_id>. The patron password C<$patron_pwd>
|
||||
may be C<undef>, if it was not provided by the terminal.
|
||||
|
||||
=head2 C<$status = $ils-E<gt>alter_hold($patron_id, $patron_pwd, $item_id, $title_id, $expiry_date, $pickup_locn, $hold_type, $fee_ack);>
|
||||
|
||||
The C<$status> object returned by C<$ils-E<gt>add_hold>,
|
||||
C<$ils-E<gt>cancel_hold>, and C<$ils-E<gt>alter_hold> must all
|
||||
support the same methods:
|
||||
|
||||
=over
|
||||
|
||||
=item C<expiration_date>
|
||||
|
||||
Returns the expiry date for the placed hold, in seconds since the
|
||||
epoch.
|
||||
|
||||
=item C<queue_position>
|
||||
|
||||
Returns the new hold's place in the queue of outstanding holds.
|
||||
|
||||
=item C<pickup_location>
|
||||
|
||||
Returns the location code for the pickup location.
|
||||
|
||||
=back
|
||||
|
||||
=head2 C<$status = $ils-E<gt>renew($patron_id, $patron_pwd, $item_id, $title_id, $no_block, $nb_due_date, $third_party, $item_props, $fee_ack);>
|
||||
|
||||
Renew the item identified by C<$item_id> or C<$title_id>, as
|
||||
requested by C<$patron_id> (with password C<$patron_pwd>). The
|
||||
item has the properties C<$item_props> associated with it.
|
||||
|
||||
If the patron renewed the item while the terminal was
|
||||
disconnected from the net, then it is a C<$no_block> transaction,
|
||||
and the due date assigned by the terminal, and reported to the
|
||||
patron was C<$nb_due_date> (so we have to honor it).
|
||||
|
||||
If there is a fee associated with renewing the item, and the
|
||||
patron has agreed to pay the fee, then C<$fee_ack> will be
|
||||
C<'Y'>.
|
||||
|
||||
If C<$third_party> is C<'Y'> and the book is not checked out to
|
||||
C<$patron_id>, but to some other person, then this is a
|
||||
third-party renewal; the item should be renewed for the person to
|
||||
whom it is checked out, rather than checking it out to
|
||||
C<$patron_id>, or the renewal should fail.
|
||||
|
||||
The C<$status> object returned by C<$ils-E<gt>renew> must support
|
||||
the following methods:
|
||||
|
||||
=over
|
||||
|
||||
=item C<renewal_ok>
|
||||
|
||||
Boolean. If C<renewal_ok> is true, then the item was already
|
||||
checked out to the patron, so it is being renewed. If
|
||||
C<renewal_ok> is false, then the patron did not already have the
|
||||
item checked out.
|
||||
|
||||
NOTE: HOW IS THIS USED IN PRACTICE?
|
||||
|
||||
=item C<desensitize>, C<security_inhibit>, C<fee_amount>, C<sip_currency>, C<sip_fee_type>, C<transaction_id>
|
||||
|
||||
See C<$ils-E<gt>checkout> for these methods.
|
||||
|
||||
=back
|
||||
|
||||
=head2 C<$status = $ils-E<gt>renew_all($patron_id, $patron_pwd, $fee_ack);>
|
||||
|
||||
Renew all items checked out by C<$patron_id> (with password
|
||||
C<$patron_pwd>). If the patron has agreed to pay any fees
|
||||
associated with this transaction, then C<$fee_ack> will be
|
||||
C<'Y'>.
|
||||
|
||||
The C<$status> object must support the following methods:
|
||||
|
||||
=over
|
||||
|
||||
=item C<renewed>
|
||||
|
||||
Returns a list of the C<$item_id>s of the items that were renewed.
|
||||
|
||||
=item C<unrenewed>
|
||||
|
||||
Returns a list of the C<$item_id>s of the items that were not renewed.
|
||||
|
||||
=back
|
||||
|
|
@ -0,0 +1,214 @@
|
|||
#
|
||||
# ILS::Item.pm
|
||||
#
|
||||
# A Class for hiding the ILS's concept of the item from the OpenSIP
|
||||
# system
|
||||
#
|
||||
|
||||
package ILS::Item;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Sys::Syslog qw(syslog);
|
||||
|
||||
use ILS::Transaction;
|
||||
|
||||
our %item_db = (
|
||||
'1565921879' => {
|
||||
title => "Perl 5 desktop reference",
|
||||
id => '1565921879',
|
||||
sip_media_type => '001',
|
||||
magnetic_media => 0,
|
||||
hold_queue => [],
|
||||
},
|
||||
'0440242746' => {
|
||||
title => "The deep blue alibi",
|
||||
id => '0440242746',
|
||||
sip_media_type => '001',
|
||||
magnetic_media => 0,
|
||||
hold_queue => [],
|
||||
},
|
||||
'660' => {
|
||||
title => "Harry Potter y el cáliz de fuego",
|
||||
id => '660',
|
||||
sip_media_type => '001',
|
||||
magnetic_media => 0,
|
||||
hold_queue => [],
|
||||
},
|
||||
);
|
||||
|
||||
sub new {
|
||||
my ($class, $item_id) = @_;
|
||||
my $type = ref($class) || $class;
|
||||
my $self;
|
||||
|
||||
|
||||
if (!exists($item_db{$item_id})) {
|
||||
syslog("LOG_DEBUG", "new ILS::Item('%s'): not found", $item_id);
|
||||
return undef;
|
||||
}
|
||||
|
||||
$self = $item_db{$item_id};
|
||||
bless $self, $type;
|
||||
|
||||
syslog("LOG_DEBUG", "new ILS::Item('%s'): found with title '%s'",
|
||||
$item_id, $self->{title});
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub magnetic {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{magnetic_media};
|
||||
}
|
||||
|
||||
sub sip_media_type {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{sip_media_type};
|
||||
}
|
||||
|
||||
sub sip_item_properties {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{sip_item_properties};
|
||||
}
|
||||
|
||||
sub status_update {
|
||||
my ($self, $props) = @_;
|
||||
my $status = new ILS::Transaction;
|
||||
|
||||
$self->{sip_item_properties} = $props;
|
||||
$status->{ok} = 1;
|
||||
|
||||
return $status;
|
||||
}
|
||||
|
||||
|
||||
sub id {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{id};
|
||||
}
|
||||
|
||||
sub title_id {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{title};
|
||||
}
|
||||
|
||||
sub permanent_location {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{permanent_location} || '';
|
||||
}
|
||||
|
||||
sub current_location {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{current_location} || '';
|
||||
}
|
||||
|
||||
sub sip_circulation_status {
|
||||
my $self = shift;
|
||||
|
||||
if ($self->{patron}) {
|
||||
return '04';
|
||||
} elsif (scalar @{$self->{hold_queue}}) {
|
||||
return '08';
|
||||
} else {
|
||||
return '03';
|
||||
}
|
||||
}
|
||||
|
||||
sub sip_security_marker {
|
||||
return '02';
|
||||
}
|
||||
|
||||
sub sip_fee_type {
|
||||
return '01';
|
||||
}
|
||||
|
||||
sub fee {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{fee} || 0;
|
||||
}
|
||||
|
||||
sub fee_currency {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{currency} || 'CAD';
|
||||
}
|
||||
|
||||
sub owner {
|
||||
my $self = shift;
|
||||
|
||||
return 'UWOLS';
|
||||
}
|
||||
|
||||
sub hold_queue {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{hold_queue};
|
||||
}
|
||||
|
||||
sub hold_queue_position {
|
||||
my ($self, $patron_id) = @_;
|
||||
my $i;
|
||||
|
||||
for ($i = 0; $i < scalar @{$self->{hold_queue}}; $i += 1) {
|
||||
if ($self->{hold_queue}[$i]->{patron_id} eq $patron_id) {
|
||||
return $i + 1;
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub due_date {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{due_date} || 0;
|
||||
}
|
||||
|
||||
sub recall_date {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{recall_date} || 0;
|
||||
}
|
||||
|
||||
sub hold_pickup_date {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{hold_pickup_date} || 0;
|
||||
}
|
||||
|
||||
sub screen_msg {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{screen_msg} || '';
|
||||
}
|
||||
|
||||
sub print_line {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{print_line} || '';
|
||||
}
|
||||
|
||||
# An item is available for a patron if
|
||||
# 1) It's not checked out and (there's no hold queue OR patron
|
||||
# is at the front of the queue)
|
||||
# OR
|
||||
# 2) It's checked out to the patron and there's no hold queue
|
||||
sub available {
|
||||
my ($self, $for_patron) = @_;
|
||||
|
||||
return ((!defined($self->{patron_id}) && (!scalar @{$self->{hold_queue}}
|
||||
|| ($self->{hold_queue}[0] eq $for_patron)))
|
||||
|| ($self->{patron_id} && ($self->{patron_id} eq $for_patron)
|
||||
&& !scalar @{$self->{hold_queue}}));
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,231 @@
|
|||
=head1 NAME
|
||||
|
||||
ILS::Item - Portable Item status object class for SIP
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use ILS;
|
||||
use ILS::Item;
|
||||
|
||||
# Look up item based on item_id
|
||||
my $item = new ILS::Item $item_id;
|
||||
|
||||
# Basic object access methods
|
||||
$item_id = $item->id;
|
||||
$title = $item->title_id;
|
||||
$media_type = $item->sip_media_type;
|
||||
$bool = $item->magnetic;
|
||||
$locn = $item->permanent_location;
|
||||
$locn = $item->current_location;
|
||||
$props = $item->sip_item_props;
|
||||
$owner = $item->owner;
|
||||
$str = $item->sip_circulation_status;
|
||||
$bool = $item->available;
|
||||
@hold_queue = $item->hold_queue;
|
||||
$pos = $item->hold_queue_position($patron_id);
|
||||
$due = $item->due_date;
|
||||
$pickup = $item->hold_pickup_date;
|
||||
$recall = $item->recall_date;
|
||||
$fee = $item->fee;
|
||||
$currency = $item->fee_currency;
|
||||
$type = $item->sip_fee_type;
|
||||
$mark = $item->sip_security_marker;
|
||||
$msg = $item->screen_msg;
|
||||
$msg = $item->print_line;
|
||||
|
||||
# Operations on items
|
||||
$status = $item->status_update($item_props);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
An C<ILS::Item> object holds the information necessary to
|
||||
circulate an item in the library's collection. It does not need
|
||||
to be a complete bibliographic description of the item; merely
|
||||
basic human-appropriate identifying information is necessary
|
||||
(that is, not the barcode, but just a title, and maybe author).
|
||||
|
||||
For the most part, C<ILS::Item>s are not operated on directly,
|
||||
but are passed to C<ILS> methods as part of a transaction. That
|
||||
is, rather than having an item check itself in:
|
||||
|
||||
$item->checkin;
|
||||
|
||||
the code tells the ILS that the item has returned:
|
||||
|
||||
$ils->checkin($item_id);
|
||||
|
||||
Similarly, patron's don't check things out (a la,
|
||||
C<$patron-E<gt>checkout($item)>), but the ILS checks items out to
|
||||
patrons. This means that the methods that are defined for items
|
||||
are, almost exclusively, methods to retrieve information about
|
||||
the state of the item.
|
||||
|
||||
=over
|
||||
|
||||
=item C<$item_id = $item-E<gt>id>
|
||||
|
||||
Return the item ID, or barcode, of C<$item>.
|
||||
|
||||
=item C<$title = $item-E<gt>title_id>
|
||||
|
||||
Return the title, or some other human-relevant description, of
|
||||
the item.
|
||||
|
||||
=item C<$media_type = $item-E<gt>media_type>
|
||||
|
||||
Return the SIP-defined media type of the item. The specification
|
||||
provides the following definitions:
|
||||
|
||||
000 Other
|
||||
001 Book
|
||||
002 Magazine
|
||||
003 Bound journal
|
||||
004 Audio tape
|
||||
005 Video tape
|
||||
006 CD/CDROM
|
||||
007 Diskette
|
||||
008 Book with diskette
|
||||
009 Book with CD
|
||||
010 Book with audio tape
|
||||
|
||||
The SIP server does not use the media type code to alter its
|
||||
behavior at all; it merely passes it through to the self-service
|
||||
terminal. In particular, it does not set indicators related to
|
||||
whether an item is magnetic, or whether it should be
|
||||
desensitized, based on this return type. The
|
||||
C<$item-E<gt>magnetic> method will be used for that purpose.
|
||||
|
||||
=item C<magnetic>
|
||||
|
||||
Is the item some form of magnetic media (eg, a video or a book
|
||||
with an accompanying floppy)? This method will not be called
|
||||
unless
|
||||
|
||||
$ils->supports('magnetic media')
|
||||
|
||||
returns C<true>.
|
||||
|
||||
If this method is defined, it is assumed to return either C<true>
|
||||
or C<false> for every item. If the magnetic media indication is
|
||||
not supported by the ILS, then the SIP server will indicate that
|
||||
all items are 'Unknown'.
|
||||
|
||||
=item C<$locn = $item-E<gt>permanent_location>
|
||||
|
||||
Where does this item normally reside? The protocol specification
|
||||
is not clear on whether this is the item's "home branch", or a
|
||||
location code within the branch, merely stating that it is, "The
|
||||
location where an item is normally stored after being checked
|
||||
in."
|
||||
|
||||
=item C<$locn = $item-E<gt>current_location>
|
||||
|
||||
According to the protocol, "[T]he current location of the item.
|
||||
[A checkin terminal] could set this field to the ... system
|
||||
terminal location on a Checkin message."
|
||||
|
||||
=item C<$props = $item-E<gt>sip_item_props>
|
||||
|
||||
Returns "item properties" associated with the item. This is an
|
||||
(optional) opaque string that is passed between the self-service
|
||||
terminals and the ILS. It can be set by the terminal, and should
|
||||
be stored in the ILS if it is.
|
||||
|
||||
=item C<$owner = $item-E<gt>owner>
|
||||
|
||||
The spec says, "This field might contain the name of the
|
||||
institution or library that owns the item."
|
||||
|
||||
=item C<$str = $item-E<gt>sip_circulation_status>
|
||||
|
||||
Returns a two-character string describing the circulation status
|
||||
of the item, as defined in the specification:
|
||||
|
||||
01 Other
|
||||
02 On order
|
||||
03 Available
|
||||
04 Charged
|
||||
05 Charged; not to be recalled until earliest recall date
|
||||
06 In process
|
||||
07 Recalled
|
||||
08 Waiting on hold shelf
|
||||
09 Waiting to be re-shelved
|
||||
10 In transit between library locations
|
||||
11 Claimed returned
|
||||
12 Lost
|
||||
13 Missing
|
||||
|
||||
=item C<$bool = $item-E<gt>available>
|
||||
|
||||
Is the item available? That is, not checked out, and not on the
|
||||
hold shelf?
|
||||
|
||||
=item C<@hold_queue = $item-E<gt>hold_queue>
|
||||
|
||||
Returns a list of the C<$patron_id>s of the patrons that have
|
||||
outstanding holds on the item.
|
||||
|
||||
=item C<$pos = $item-E<gt>hold_queue_position($patron_id)>
|
||||
|
||||
Returns the location of C<$patron_id> in the hold queue for the
|
||||
item, with '1' indicating the next person to receive the item. A
|
||||
return status of '0' indicates that C<$patron_id> does not have a
|
||||
hold on the item.
|
||||
|
||||
=item C<$date = $item-E<gt>recall_date>
|
||||
=item C<$date = $item-E<gt>hold_pickup_date>
|
||||
|
||||
These functions all return the corresponding date as a standard
|
||||
SIP-format timestamp:
|
||||
|
||||
YYYYMMDDZZZZHHMMSS
|
||||
|
||||
Where the C<'Z'> characters indicate spaces.
|
||||
|
||||
=item C<$date = $item-E<gt>due_date>
|
||||
|
||||
Returns the date the item is due. The format for this timestamp
|
||||
is not defined by the specification, but it should be something
|
||||
simple for a human reader to understand.
|
||||
|
||||
=item C<$fee = $item-E<gt>fee>
|
||||
|
||||
The amount of the fee associated with borrowing this item.
|
||||
|
||||
=item C<$currency = $item-E<gt>fee_currency>
|
||||
|
||||
The currency in which the fee type above is denominated. This
|
||||
field is the ISO standard 4217 three-character currency code. It
|
||||
is highly unlikely that many systems will denominate fees in more
|
||||
than one currency, however.
|
||||
|
||||
=item C<$type = $item-E<gt>sip_fee_type>
|
||||
|
||||
The type of fee being charged, as defined by the SIP protocol
|
||||
specification:
|
||||
|
||||
01 Other/unknown
|
||||
02 Administrative
|
||||
03 Damage
|
||||
04 Overdue
|
||||
05 Processing
|
||||
06 Rental
|
||||
07 Replacement
|
||||
08 Computer access charge
|
||||
09 Hold fee
|
||||
|
||||
=item C<$mark = $item-E<gt>sip_security_marker>
|
||||
|
||||
The type of security system with which the item is tagged:
|
||||
|
||||
00 Other
|
||||
01 None
|
||||
02 3M Tattle-tape
|
||||
03 3M Whisper tape
|
||||
|
||||
=item C<$msg = $item-E<gt>screen_msg>
|
||||
=item C<$msg = $item-E<gt>print_line>
|
||||
|
||||
The usual suspects.
|
||||
|
||||
=back
|
||||
|
|
@ -0,0 +1,393 @@
|
|||
#
|
||||
# ILS::Patron.pm
|
||||
#
|
||||
# A Class for hiding the ILS's concept of the patron from the OpenSIP
|
||||
# system
|
||||
#
|
||||
|
||||
package ILS::Patron;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Exporter;
|
||||
|
||||
use Sys::Syslog qw(syslog);
|
||||
use Data::Dumper;
|
||||
|
||||
our (@ISA, @EXPORT_OK);
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
|
||||
@EXPORT_OK = qw(invalid_patron);
|
||||
|
||||
our %patron_db = (
|
||||
djfiander => {
|
||||
name => "David J. Fiander",
|
||||
id => 'djfiander',
|
||||
password => '6789',
|
||||
ptype => 'A', # 'A'dult. Whatever.
|
||||
birthdate => '19640925',
|
||||
address => '2 Meadowvale Dr. St Thomas, ON',
|
||||
home_phone => '(519) 555 1234',
|
||||
email_addr => 'djfiander@hotmail.com',
|
||||
charge_ok => 1,
|
||||
renew_ok => 1,
|
||||
recall_ok => 0,
|
||||
hold_ok => 1,
|
||||
card_lost => 0,
|
||||
claims_returned => 0,
|
||||
fines => 100,
|
||||
fees => 0,
|
||||
recall_overdue => 0,
|
||||
items_billed => 0,
|
||||
screen_msg => '',
|
||||
print_line => '',
|
||||
items => [],
|
||||
hold_items => [],
|
||||
overdue_items => [],
|
||||
fine_items => ['Computer Time'],
|
||||
recall_items => [],
|
||||
unavail_holds => [],
|
||||
inet => 1,
|
||||
},
|
||||
miker => {
|
||||
name => "Mike Rylander",
|
||||
id => 'miker',
|
||||
password => '6789',
|
||||
ptype => 'A', # 'A'dult. Whatever.
|
||||
birthdate => '19640925',
|
||||
address => 'Somewhere in Atlanta',
|
||||
home_phone => '(404) 555 1235',
|
||||
email_addr => 'mrylander@gmail.com',
|
||||
charge_ok => 1,
|
||||
renew_ok => 1,
|
||||
recall_ok => 0,
|
||||
hold_ok => 1,
|
||||
card_lost => 0,
|
||||
claims_returned => 0,
|
||||
fines => 0,
|
||||
fees => 0,
|
||||
recall_overdue => 0,
|
||||
items_billed => 0,
|
||||
screen_msg => '',
|
||||
print_line => '',
|
||||
items => [],
|
||||
hold_items => [],
|
||||
overdue_items => [],
|
||||
fine_items => [],
|
||||
recall_items => [],
|
||||
unavail_holds => [],
|
||||
inet => 0,
|
||||
},
|
||||
);
|
||||
|
||||
sub new {
|
||||
my ($class, $patron_id) = @_;
|
||||
my $type = ref($class) || $class;
|
||||
my $self;
|
||||
|
||||
if (!exists($patron_db{$patron_id})) {
|
||||
syslog("LOG_DEBUG", "new ILS::Patron(%s): no such patron", $patron_id);
|
||||
return undef;
|
||||
}
|
||||
|
||||
$self = $patron_db{$patron_id};
|
||||
|
||||
syslog("LOG_DEBUG", "new ILS::Patron(%s): found patron '%s'", $patron_id,
|
||||
$self->{id});
|
||||
|
||||
bless $self, $type;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub id {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{id};
|
||||
}
|
||||
|
||||
sub name {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{name};
|
||||
}
|
||||
|
||||
sub address {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{address};
|
||||
}
|
||||
|
||||
sub email_addr {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{email_addr};
|
||||
}
|
||||
|
||||
sub home_phone {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{home_phone};
|
||||
}
|
||||
|
||||
sub sip_birthdate {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{birthdate};
|
||||
}
|
||||
|
||||
sub ptype {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{ptype};
|
||||
}
|
||||
|
||||
sub language {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{language} || '000'; # Unspecified
|
||||
}
|
||||
|
||||
sub charge_ok {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{charge_ok};
|
||||
}
|
||||
|
||||
sub renew_ok {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{renew_ok};
|
||||
}
|
||||
|
||||
sub recall_ok {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{recall_ok};
|
||||
}
|
||||
|
||||
sub hold_ok {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{hold_ok};
|
||||
}
|
||||
|
||||
sub card_lost {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{card_lost};
|
||||
}
|
||||
|
||||
sub recall_overdue {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{recall_overdue};
|
||||
}
|
||||
|
||||
sub check_password {
|
||||
my ($self, $pwd) = @_;
|
||||
|
||||
# If the patron doesn't have a password,
|
||||
# then we don't need to check
|
||||
return (!$self->{password} || ($pwd && ($self->{password} eq $pwd)));
|
||||
}
|
||||
|
||||
sub currency {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{currency};
|
||||
}
|
||||
|
||||
sub fee_amount {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{fee_amount} || undef;
|
||||
}
|
||||
|
||||
sub screen_msg {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{screen_msg};
|
||||
}
|
||||
|
||||
sub print_line {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{print_line};
|
||||
}
|
||||
|
||||
sub too_many_charged {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{too_many_charged};
|
||||
}
|
||||
|
||||
sub too_many_overdue {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{too_many_overdue};
|
||||
}
|
||||
|
||||
sub too_many_renewal {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{too_many_renewal};
|
||||
}
|
||||
|
||||
sub too_many_claim_return {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{too_many_claim_return};
|
||||
}
|
||||
|
||||
sub too_many_lost {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{too_many_lost};
|
||||
}
|
||||
|
||||
sub excessive_fines {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{excessive_fines};
|
||||
}
|
||||
|
||||
sub excessive_fees {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{excessive_fees};
|
||||
}
|
||||
|
||||
sub too_many_billed {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{too_many_billed};
|
||||
}
|
||||
|
||||
#
|
||||
# List of outstanding holds placed
|
||||
#
|
||||
sub hold_items {
|
||||
my ($self, $start, $end) = @_;
|
||||
|
||||
$start = 1 if !defined($start);
|
||||
$end = scalar @{$self->{hold_items}} if !defined($end);
|
||||
|
||||
return [@{$self->{hold_items}}[$start-1 .. $end-1]];
|
||||
}
|
||||
|
||||
#
|
||||
# remove the hold on item item_id from my hold queue.
|
||||
# return true if I was holding the item, false otherwise.
|
||||
#
|
||||
sub drop_hold {
|
||||
my ($self, $item_id) = @_;
|
||||
my $i;
|
||||
|
||||
for ($i = 0; $i < scalar @{$self->{hold_items}}; $i += 1) {
|
||||
if ($self->{hold_items}[$i]->{item_id} eq $item_id) {
|
||||
splice @{$self->{hold_items}}, $i, 1;
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub overdue_items {
|
||||
my ($self, $start, $end) = @_;
|
||||
|
||||
$start = 1 if !defined($start);
|
||||
$end = scalar @{$self->{overdue_items}} if !defined($end);
|
||||
|
||||
return [@{$self->{overdue_items}}[$start-1 .. $end-1]];
|
||||
}
|
||||
|
||||
sub charged_items {
|
||||
my ($self, $start, $end) = shift;
|
||||
|
||||
$start = 1 if !defined($start);
|
||||
$end = scalar @{$self->{items}} if !defined($end);
|
||||
|
||||
syslog("LOG_DEBUG", "charged_items: start = %d, end = %d", $start, $end);
|
||||
syslog("LOG_DEBUG", "charged_items: items = (%s)",
|
||||
join(', ', @{$self->{items}}));
|
||||
|
||||
return [@{$self->{items}}[$start-1 .. $end-1]];
|
||||
}
|
||||
|
||||
sub fine_items {
|
||||
my ($self, $start, $end) = @_;
|
||||
|
||||
$start = 1 if !defined($start);
|
||||
$end = scalar @{$self->{fine_items}} if !defined($end);
|
||||
|
||||
return [@{$self->{fine_items}}[$start-1 .. $end-1]];
|
||||
}
|
||||
|
||||
sub recall_items {
|
||||
my ($self, $start, $end) = @_;
|
||||
|
||||
$start = 1 if !defined($start);
|
||||
$end = scalar @{$self->{recall_items}} if !defined($end);
|
||||
|
||||
return [@{$self->{recall_items}}[$start-1 .. $end-1]];
|
||||
}
|
||||
|
||||
sub unavail_holds {
|
||||
my ($self, $start, $end) = @_;
|
||||
|
||||
$start = 1 if !defined($start);
|
||||
$end = scalar @{$self->{unavail_holds}} if !defined($end);
|
||||
|
||||
return [@{$self->{unavail_holds}}[$start-1 .. $end-1]];
|
||||
}
|
||||
|
||||
sub block {
|
||||
my ($self, $card_retained, $blocked_card_msg) = @_;
|
||||
|
||||
foreach my $field ('charge_ok', 'renew_ok', 'recall_ok', 'hold_ok') {
|
||||
$self->{$field} = 0;
|
||||
}
|
||||
|
||||
$self->{screen_msg} = $blocked_card_msg || "Card Blocked. Please contact library staff";
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub enable {
|
||||
my $self = shift;
|
||||
|
||||
foreach my $field ('charge_ok', 'renew_ok', 'recall_ok', 'hold_ok') {
|
||||
$self->{$field} = 1;
|
||||
}
|
||||
|
||||
syslog("LOG_DEBUG", "Patron(%s)->enable: charge: %s, renew:%s, recall:%s, hold:%s",
|
||||
$self->{id}, $self->{charge_ok}, $self->{renew_ok},
|
||||
$self->{recall_ok}, $self->{hold_ok});
|
||||
|
||||
$self->{screen_msg} = "All privileges restored.";
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
||||
sub inet_privileges {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{inet} ? 'Y' : 'N';
|
||||
}
|
||||
|
||||
#
|
||||
# Messages
|
||||
#
|
||||
|
||||
sub invalid_patron {
|
||||
return "Please contact library staff";
|
||||
}
|
||||
|
||||
sub charge_denied {
|
||||
return "Please contact library staff";
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,210 @@
|
|||
=head1 NAME
|
||||
|
||||
ILS::Patron - Portable Patron status object class for SIP
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A C<ILS::Patron> object holds information about a patron that's
|
||||
used by self service terminals to authenticate and authorize a patron,
|
||||
and to display information about the patron's borrowing activity.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use ILS;
|
||||
use ILS::Patron;
|
||||
|
||||
# Look up patron based on patron_id
|
||||
my $patron = new ILS::Patron $patron_id
|
||||
|
||||
# Basic object access methods
|
||||
$patron_id = $patron->id;
|
||||
$str = $patron->name;
|
||||
$str = $patron->address;
|
||||
$str = $patron->email_addr;
|
||||
$str = $patron->home_phone;
|
||||
$str = $patron->sip_birthdate;
|
||||
$str = $patron->ptype;
|
||||
$str = $patron->language;
|
||||
$str = $patron->password;
|
||||
$str = $patron->check_password($password);
|
||||
$str = $patron->currency;
|
||||
$str = $patron->screen_msg;
|
||||
$str = $patron->print_line;
|
||||
|
||||
# Check patron permissions
|
||||
$bool = $patron->charge_ok;
|
||||
$bool = $patron->renew_ok;
|
||||
$bool = $patron->recall_ok;
|
||||
$bool = $patron->hold_ok;
|
||||
$bool = $patron->card_lost;
|
||||
$bool = $patron->too_many_charged;
|
||||
$bool = $patron->too_many_overdue;
|
||||
$bool = $patron->too_many_renewal;
|
||||
$bool = $patron->too_many_claim_return;
|
||||
$bool = $patron->too_many_lost;
|
||||
$bool = $patron->excessive_fines;
|
||||
$bool = $patron->excessive_fees;
|
||||
$bool = $patron->too_many_billed;
|
||||
|
||||
# Patron borrowing activity
|
||||
$num = $patron->recall_overdue;
|
||||
$num = $patron->fee_amount;
|
||||
$bool = $patron->drop_hold($item_id);
|
||||
@holds = $patron->hold_items($start, $end);
|
||||
@items = $patron->overdue_items($start, $end);
|
||||
@items = $patron->charged_items($start, $end);
|
||||
@items = $patron->fine_items($start, $end);
|
||||
@items = $patron->recall_items($start, $end);
|
||||
@items = $patron->unavail_holds($start, $end);
|
||||
|
||||
# Changing a patron's status
|
||||
$patron->block($card_retained, $blocked_msg);
|
||||
$patron->enable;
|
||||
|
||||
=head1 INITIALIZATION
|
||||
|
||||
A patron object is created by calling
|
||||
|
||||
$patron = new ILS::Patron $patron_id;
|
||||
|
||||
where C<$patron_id> is the patron's barcode as received from the
|
||||
self service terminal. If the patron barcode is not registered,
|
||||
then C<new> should return C<undef>.
|
||||
|
||||
=head1 BASIC OBJECT ACCESS METHODS
|
||||
|
||||
The following functions return the corresponding information
|
||||
about the given patron, or C<undef> if the information is
|
||||
unavailable.
|
||||
|
||||
$patron_id = $patron-E<gt>id;
|
||||
$str = $patron-E<gt>name;
|
||||
$str = $patron-E<gt>address;
|
||||
$str = $patron-E<gt>email_addr;
|
||||
$str = $patron-E<gt>home_phone;
|
||||
|
||||
$str = $patron-E<gt>screen_msg;
|
||||
$str = $patron-E<gt>print_line;
|
||||
|
||||
If there are outstanding display messages associated with the
|
||||
patron, then these return the screen message and print line,
|
||||
respectively, as with the C<ILS> methods.
|
||||
|
||||
There are a few other object access methods that need a bit more
|
||||
explication however.
|
||||
|
||||
=head2 C<$str = $patron-E<gt>sip_birthdate;>
|
||||
|
||||
Returns the patron's birthday formated according to the SIP
|
||||
specification:
|
||||
|
||||
YYYYMMDD HHMMSS
|
||||
|
||||
=head2 C<$str = $patron-E<gt>ptype;>
|
||||
|
||||
Returns the "patron type" of the patron. This is not used by the
|
||||
SIP server code, but is passed through to the self service
|
||||
terminal (using the non-standard protocol field "PC"). Some self
|
||||
service terminals use the patron type in determining what level
|
||||
of service to provide (for example, Envisionware computer
|
||||
management software can be configured to filter internet access
|
||||
based on patron type).
|
||||
|
||||
=head2 C<$str = $patron-E<gt>language;>
|
||||
|
||||
A three-digit string encoding the patron's prefered language.
|
||||
The full list is defined in the SIP specification, but some of
|
||||
the important values are:
|
||||
|
||||
000 Unknown (default)
|
||||
001 English
|
||||
002 French
|
||||
008 Spanish
|
||||
011 Canadian French
|
||||
016 Arabic
|
||||
019 Chinese
|
||||
021 North American Spanish
|
||||
|
||||
=head2 C<$bool = $patron-E<gt>check_password($password);>
|
||||
|
||||
Returns C<true> if C<$patron>'s password is C<$password>.
|
||||
|
||||
=head2 C<$str = $patron-E<gt>currency;>
|
||||
|
||||
Returns the three character ISO 4217 currency code for the
|
||||
patron's preferred currency.
|
||||
|
||||
=head1 CHECKING PATRON PERMISSIONS
|
||||
|
||||
Most of the methods associated with Patrons are related to
|
||||
checking if they're authorized to perform various actions:
|
||||
|
||||
$bool = $patron-E<gt>charge_ok;
|
||||
$bool = $patron-E<gt>renew_ok;
|
||||
$bool = $patron-E<gt>recall_ok;
|
||||
$bool = $patron-E<gt>hold_ok;
|
||||
$bool = $patron-E<gt>card_lost;
|
||||
$bool = $patron-E<gt>recall_overdue;
|
||||
$bool = $patron-E<gt>too_many_charged;
|
||||
$bool = $patron-E<gt>too_many_overdue;
|
||||
$bool = $patron-E<gt>too_many_renewal;
|
||||
$bool = $patron-E<gt>too_many_claim_return;
|
||||
$bool = $patron-E<gt>too_many_lost;
|
||||
$bool = $patron-E<gt>excessive_fines;
|
||||
$bool = $patron-E<gt>excessive_fees;
|
||||
$bool = $patron-E<gt>too_many_billed;
|
||||
|
||||
=head1 LISTS OF ITEMS ASSOCIATED WITH THE USER
|
||||
|
||||
The C<$patron> object provides a set of methods to find out
|
||||
information about various sets that are associated with the
|
||||
user. All these methods take two optional parameters: C<$start>
|
||||
and C<$end>, which define a subset of the list of items to be
|
||||
returned (C<1> is the first item in the list). The following
|
||||
methods all return a reference to a list of C<$item_id>s:
|
||||
|
||||
$items = $patron-E<gt>hold_items($start, $end);
|
||||
$items = $patron-E<gt>overdue_items($start, $end);
|
||||
$items = $patron-E<gt>charged_items($start, $end);
|
||||
$items = $patron-E<gt>recall_items($start, $end);
|
||||
$items = $patron-E<gt>unavail_holds($start, $end);
|
||||
|
||||
It is also possible to retrieve an itemized list of the fines
|
||||
outstanding. This method returns a reference to an itemized list
|
||||
of fines:
|
||||
|
||||
$fines = $patron-E<gt>fine_items($start, $end);
|
||||
|
||||
=head1 PATRON BORROWING ACTIVITY
|
||||
|
||||
=head2 C<$num = $patron-E<gt>fee_amount;>
|
||||
|
||||
The total amount of fees and fines owed by the patron.
|
||||
|
||||
=head2 C<$bool = $patron-E<gt>drop_hold($item_id);>
|
||||
|
||||
Drops the hold that C<$patron> has placed on the item
|
||||
C<$item_id>. Returns C<false> if the patron did not have a hold
|
||||
on the item, C<true> otherwise.
|
||||
|
||||
|
||||
|
||||
=head1 CHANGING A PATRON'S STATUS
|
||||
|
||||
=head2 C<$status = $ils-E<gt>block($card_retained, $blocked_card_msg);>
|
||||
|
||||
Block the account of the patron identified by C<$patron_id>. If
|
||||
the self check unit captured the patron's card, then
|
||||
C<$card_retained> will be C<true>. A message indicating why the
|
||||
card was retained will be provided by the parameter
|
||||
C<$blocked_card_msg>.
|
||||
|
||||
This function returns an C<ILS::Patron> object that has been
|
||||
updated to indicate that the patron's privileges have been
|
||||
blocked, or C<undef> if the patron ID is not valid.
|
||||
|
||||
=head2 C<$patron-E<gt>enable;>
|
||||
|
||||
Reenable the patron after she's been blocked. This is a test
|
||||
function and will not normally be called by self-service
|
||||
terminals in production.
|
||||
|
|
@ -0,0 +1,59 @@
|
|||
#
|
||||
# Transaction: Superclass of all the transactional status objects
|
||||
#
|
||||
|
||||
package ILS::Transaction;
|
||||
|
||||
use Carp;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
my %fields = (
|
||||
ok => 0,
|
||||
patron => undef,
|
||||
item => undef,
|
||||
desensitize => 0,
|
||||
alert => '',
|
||||
transation_id => undef,
|
||||
sip_fee_type => '01', # Other/Unknown
|
||||
fee_amount => undef,
|
||||
sip_currency => 'CAD',
|
||||
screen_msg => '',
|
||||
print_line => '',
|
||||
);
|
||||
|
||||
our $AUTOLOAD;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $self = {
|
||||
_permitted => \%fields,
|
||||
%fields,
|
||||
};
|
||||
|
||||
return bless $self, $class;
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
# be cool
|
||||
}
|
||||
|
||||
sub AUTOLOAD {
|
||||
my $self = shift;
|
||||
my $class = ref($self) or croak "$self is not an object";
|
||||
my $name = $AUTOLOAD;
|
||||
|
||||
$name =~ s/.*://;
|
||||
|
||||
unless (exists $self->{_permitted}->{$name}) {
|
||||
croak "Can't access '$name' field of class '$class'";
|
||||
}
|
||||
|
||||
if (@_) {
|
||||
return $self->{$name} = shift;
|
||||
} else {
|
||||
return $self->{$name};
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
#
|
||||
# An object to handle checkin status
|
||||
#
|
||||
|
||||
package ILS::Transaction::Checkin;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
|
||||
use POSIX qw(strftime);
|
||||
|
||||
use ILS;
|
||||
use ILS::Transaction;
|
||||
|
||||
our @ISA = qw(ILS::Transaction);
|
||||
|
||||
my %fields = (
|
||||
magnetic => 0,
|
||||
sort_bin => undef,
|
||||
);
|
||||
|
||||
sub new {
|
||||
my $class = shift;;
|
||||
my $self = $class->SUPER::new();
|
||||
my $element;
|
||||
|
||||
foreach $element (keys %fields) {
|
||||
$self->{_permitted}->{$element} = $fields{$element};
|
||||
}
|
||||
|
||||
@{$self}{keys %fields} = values %fields;
|
||||
|
||||
return bless $self, $class;
|
||||
}
|
||||
|
||||
sub resensitize {
|
||||
my $self = shift;
|
||||
|
||||
return !$self->{item}->magnetic;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
#
|
||||
# An object to handle checkout status
|
||||
#
|
||||
|
||||
package ILS::Transaction::Checkout;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
|
||||
use POSIX qw(strftime);
|
||||
|
||||
use ILS;
|
||||
use ILS::Transaction;
|
||||
|
||||
our @ISA = qw(ILS::Transaction);
|
||||
|
||||
# Most fields are handled by the Transaction superclass
|
||||
my %fields = (
|
||||
security_inhibit => 0,
|
||||
due => undef,
|
||||
renew_ok => 0,
|
||||
);
|
||||
|
||||
sub new {
|
||||
my $class = shift;;
|
||||
my $self = $class->SUPER::new();
|
||||
my $element;
|
||||
|
||||
foreach $element (keys %fields) {
|
||||
$self->{_permitted}->{$element} = $fields{$element};
|
||||
}
|
||||
|
||||
@{$self}{keys %fields} = values %fields;
|
||||
$self->{'due'} = time() + (60*60*24*14); # two weeks hence
|
||||
|
||||
return bless $self, $class;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
package ILS::Transaction::FeePaid;
|
||||
|
||||
use Exporter;
|
||||
use warnings;
|
||||
use strict;
|
||||
|
||||
use ILS;
|
||||
use ILS::Transaction;
|
||||
|
||||
our @ISA = qw(Exporter ILS::Transaction);
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
#
|
||||
# status of a Hold transaction
|
||||
|
||||
package ILS::Transaction::Hold;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
|
||||
use ILS;
|
||||
use ILS::Transaction;
|
||||
|
||||
our @ISA = qw(ILS::Transaction);
|
||||
|
||||
my %fields = (
|
||||
expiration_date => 0,
|
||||
pickup_location => undef,
|
||||
);
|
||||
|
||||
sub new {
|
||||
my $class = shift;;
|
||||
my $self = $class->SUPER::new();
|
||||
my $element;
|
||||
|
||||
foreach $element (keys %fields) {
|
||||
$self->{_permitted}->{$element} = $fields{$element};
|
||||
}
|
||||
|
||||
@{$self}{keys %fields} = values %fields;
|
||||
|
||||
return bless $self, $class;
|
||||
}
|
||||
|
||||
sub queue_position {
|
||||
my $self = shift;
|
||||
|
||||
return $self->item->hold_queue_position($self->patron->id);
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
#
|
||||
# Status of a Renew Transaction
|
||||
#
|
||||
|
||||
package ILS::Transaction::Renew;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
|
||||
use ILS;
|
||||
use ILS::Transaction;
|
||||
|
||||
our @ISA = qw(ILS::Transaction);
|
||||
|
||||
my %fields = (
|
||||
renewal_ok => 0,
|
||||
);
|
||||
|
||||
sub new {
|
||||
my $class = shift;;
|
||||
my $self = $class->SUPER::new();
|
||||
my $element;
|
||||
|
||||
foreach $element (keys %fields) {
|
||||
$self->{_permitted}->{$element} = $fields{$element};
|
||||
}
|
||||
|
||||
@{$self}{keys %fields} = values %fields;
|
||||
|
||||
return bless $self, $class;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
#
|
||||
# RenewAll: class to manage status of "Renew All" transaction
|
||||
|
||||
package ILS::Transaction::RenewAll;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our @ISA = qw(ILS::Transaction);
|
||||
|
||||
my %fields = (
|
||||
renewed => [],
|
||||
unrenewed => [],
|
||||
);
|
||||
sub new {
|
||||
my $class = shift;;
|
||||
my $self = $class->SUPER::new();
|
||||
my $element;
|
||||
|
||||
foreach $element (keys %fields) {
|
||||
$self->{_permitted}->{$element} = $fields{$element};
|
||||
}
|
||||
|
||||
@{$self}{keys %fields} = values %fields;
|
||||
|
||||
return bless $self, $class;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
#
|
||||
# There's not a lot to "make", but this simplifies the usual
|
||||
# sorts of tasks
|
||||
#
|
||||
|
||||
PODFLAGS = --htmlroot=. --podroot=.
|
||||
|
||||
.SUFFIXES: .pod .html
|
||||
|
||||
.pod.html:
|
||||
pod2html $(PODFLAGS) --outfile=$@ --infile=$<
|
||||
|
||||
all:
|
||||
@echo Nothing to make. The command '"make run"' will run the server.
|
||||
|
||||
# just run the server from the command line
|
||||
run:
|
||||
perl SIPServer.pm SIPconfig.xml
|
||||
|
||||
test:
|
||||
cd t; $(MAKE) test
|
||||
|
||||
tags:
|
||||
find . -name '*.pm' -print | etags -
|
||||
|
||||
html: ILS.html ILS/Item.html ILS/Patron.html
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
README for Open NSIP 3M-SIP Server
|
||||
|
||||
DEPENDENCIES
|
||||
|
||||
SIPServer is written entirely in Perl, but it require these CPAN
|
||||
perl modules to run:
|
||||
|
||||
Net::Server - The SIP server is a Net::Server::Prefork server
|
||||
XML::LibXML
|
||||
XML::Parser
|
||||
XML::Simple - for parsing the config file
|
||||
UNIVERSAL::require - for loading the correct ILS interface module
|
||||
Clone - for running the test cases
|
||||
|
||||
LOGGING
|
||||
|
||||
SIPServer uses syslog() for status and debugging messages. All
|
||||
syslog messages are logged using the syslog facility 'local6'.
|
||||
If you need to change this, because something else on your system
|
||||
is already using that facililty, just change the definition of
|
||||
'LOG_SIP' at the top of the file SIPServer.pm
|
||||
|
||||
Make sure to update your syslog configuration to capture facility
|
||||
'local6' and record it.
|
||||
|
|
@ -0,0 +1,273 @@
|
|||
package SIPServer;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Exporter;
|
||||
use Sys::Syslog qw(syslog);
|
||||
use Net::Server::PreFork;
|
||||
use IO::Socket::INET;
|
||||
use Socket;
|
||||
use Data::Dumper; # For debugging
|
||||
require UNIVERSAL::require;
|
||||
|
||||
#use Sip qw(readline);
|
||||
use Sip::Constants qw(:all);
|
||||
use Sip::Configuration;
|
||||
use Sip::Checksum qw(checksum verify_cksum);
|
||||
use Sip::MsgType;
|
||||
|
||||
use constant LOG_SIP => "local6"; # Local alias for the logging facility
|
||||
|
||||
our @ISA = qw(Net::Server::PreFork);
|
||||
#
|
||||
# Main
|
||||
#
|
||||
|
||||
my %transports = (
|
||||
RAW => \&raw_transport,
|
||||
telnet => \&telnet_transport,
|
||||
http => \&http_transport,
|
||||
);
|
||||
|
||||
# Read configuration
|
||||
|
||||
my $config = new Sip::Configuration $ARGV[0];
|
||||
|
||||
my @parms;
|
||||
|
||||
#
|
||||
# Ports to bind
|
||||
#
|
||||
foreach my $svc (keys %{$config->{listeners}}) {
|
||||
push @parms, "port=" . $svc;
|
||||
}
|
||||
|
||||
#
|
||||
# Logging
|
||||
#
|
||||
push @parms, "log_file=Sys::Syslog", "syslog_ident=acs-server",
|
||||
"syslog_facility=" . LOG_SIP;
|
||||
|
||||
#
|
||||
# Server Management: set parameters for the Net::Server::PreFork
|
||||
# module. The module silently ignores parameters that it doesn't
|
||||
# recognize, and complains about invalid values for parameters
|
||||
# that it does.
|
||||
#
|
||||
if (defined($config->{'server-params'})) {
|
||||
while (my ($key, $val) = each %{$config->{'server-params'}}) {
|
||||
push @parms, $key . '=' . $val;
|
||||
}
|
||||
}
|
||||
|
||||
print Dumper(@parms);
|
||||
|
||||
#
|
||||
# This is the main event.
|
||||
SIPServer->run(@parms);
|
||||
|
||||
#
|
||||
# Child
|
||||
#
|
||||
|
||||
# process_request is the callback used by Net::Server to handle
|
||||
# an incoming connection request.
|
||||
|
||||
sub process_request {
|
||||
my $self = shift;
|
||||
my $service;
|
||||
my $sockname;
|
||||
my ($sockaddr, $port, $proto);
|
||||
my $transport;
|
||||
|
||||
$self->{config} = $config;
|
||||
|
||||
$sockname = getsockname(STDIN);
|
||||
($port, $sockaddr) = sockaddr_in($sockname);
|
||||
$sockaddr = inet_ntoa($sockaddr);
|
||||
$proto = $self->{server}->{client}->NS_proto();
|
||||
|
||||
$self->{service} = $config->find_service($sockaddr, $port, $proto);
|
||||
|
||||
if (!defined($self->{service})) {
|
||||
syslog("LOG_ERR", "process_request: Unknown recognized server connection: %s:%s/%s", $sockaddr, $port, $proto);
|
||||
die "process_request: Bad server connection";
|
||||
}
|
||||
|
||||
$transport = $transports{$self->{service}->{transport}};
|
||||
|
||||
if (!defined($transport)) {
|
||||
syslog("LOG_WARN", "Unknown transport '%s', dropping", $service->{transport});
|
||||
return;
|
||||
} else {
|
||||
&$transport($self);
|
||||
}
|
||||
}
|
||||
|
||||
#
|
||||
# Transports
|
||||
#
|
||||
|
||||
sub raw_transport {
|
||||
my $self = shift;
|
||||
my ($uid, $pwd);
|
||||
my $input;
|
||||
my $service = $self->{service};
|
||||
my $strikes = 3;
|
||||
my $expect;
|
||||
my $inst;
|
||||
|
||||
eval {
|
||||
local $SIG{ALRM} = sub { die "alarm\n"; };
|
||||
syslog("LOG_DEBUG", "raw_transport: timeout is %d",
|
||||
$service->{timeout});
|
||||
while ($strikes--) {
|
||||
alarm $service->{timeout};
|
||||
$input = Sip::read_SIP_packet(*STDIN);
|
||||
alarm 0;
|
||||
|
||||
if (!$input) {
|
||||
# EOF on the socket
|
||||
syslog("LOG_INFO", "raw_transport: shutting down: EOF during login");
|
||||
return;
|
||||
}
|
||||
|
||||
$input =~ s/[\r\n]+$//sm; # Strip off trailing line terminator
|
||||
|
||||
last if Sip::MsgType::handle($input, $self, LOGIN);
|
||||
}
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
syslog("LOG_ERR", "raw_transport: LOGIN ERROR: '$@'");
|
||||
die "raw_transport: login error, exiting";
|
||||
} elsif (!$self->{account}) {
|
||||
syslog("LOG_ERR", "raw_transport: LOGIN FAILED");
|
||||
die "raw_transport: Login failed, exiting";
|
||||
}
|
||||
|
||||
syslog("LOG_DEBUG", "raw_transport: uname/inst: '%s/%s'",
|
||||
$self->{account}->{id},
|
||||
$self->{account}->{institution});
|
||||
|
||||
$self->sip_protocol_loop();
|
||||
|
||||
syslog("LOG_INFO", "raw_transport: shutting down");
|
||||
}
|
||||
|
||||
sub telnet_transport {
|
||||
my $self = shift;
|
||||
my ($uid, $pwd);
|
||||
my $strikes = 3;
|
||||
my $account = undef;
|
||||
my $input;
|
||||
my $config = $self->{config};
|
||||
|
||||
# Until the terminal has logged in, we don't trust it
|
||||
# so use a timeout to protect ourselves from hanging.
|
||||
eval {
|
||||
local $SIG{ALRM} = sub { die "alarm\n"; };
|
||||
local $|;
|
||||
my $timeout = 0;
|
||||
|
||||
$| = 1; # Unbuffered output
|
||||
$timeout = $config->{timeout} if (exists($config->{timeout}));
|
||||
|
||||
while ($strikes--) {
|
||||
print "login: ";
|
||||
alarm $timeout;
|
||||
$uid = <STDIN>;
|
||||
alarm 0;
|
||||
|
||||
print "password: ";
|
||||
alarm $timeout;
|
||||
$pwd = <STDIN>;
|
||||
alarm 0;
|
||||
|
||||
$uid =~ s/[\r\n]+$//;
|
||||
$pwd =~ s/[\r\n]+$//;
|
||||
|
||||
if (exists($config->{accounts}->{$uid})
|
||||
&& ($pwd eq $config->{accounts}->{$uid}->password())) {
|
||||
$account = $config->{accounts}->{$uid};
|
||||
last;
|
||||
} else {
|
||||
syslog("LOG_WARNING", "Invalid login attempt: '%s'", $uid);
|
||||
print("Invalid login\n");
|
||||
}
|
||||
}
|
||||
}; # End of eval
|
||||
|
||||
if ($@) {
|
||||
syslog("LOG_ERR", "telnet_transport: Login timed out");
|
||||
die "Telnet Login Timed out";
|
||||
} elsif (!defined($account)) {
|
||||
syslog("LOG_ERR", "telnet_transport: Login Failed");
|
||||
die "Login Failure";
|
||||
} else {
|
||||
print "Login OK. Initiating SIP\n";
|
||||
}
|
||||
|
||||
$self->{account} = $account;
|
||||
|
||||
$self->sip_protocol_loop();
|
||||
syslog("LOG_INFO", "telnet_transport: shutting down");
|
||||
}
|
||||
|
||||
|
||||
sub http_transport {
|
||||
}
|
||||
|
||||
#
|
||||
# The terminal has logged in, using either the SIP login process
|
||||
# over a raw socket, or via the pseudo-unix login provided by the
|
||||
# telnet transport. From that point on, both the raw and the telnet
|
||||
# processes are the same:
|
||||
sub sip_protocol_loop {
|
||||
my $self = shift;
|
||||
my $expect;
|
||||
my $service = $self->{service};
|
||||
my $config = $self->{config};
|
||||
my $input;
|
||||
|
||||
# Now that the terminal has logged in, the first message
|
||||
# we recieve must be an SC_STATUS message. But it might be
|
||||
# an SC_REQUEST_RESEND. So, as long as we keep receiving
|
||||
# SC_REQUEST_RESEND, we keep waiting for an SC_STATUS
|
||||
|
||||
# Comprise reports that no other ILS actually enforces this
|
||||
# constraint, so we'll relax about it too. As long as everybody
|
||||
# uses the SIP "raw" login process, rather than telnet, this
|
||||
# will be fine, becaues the LOGIN protocol exchange will force
|
||||
# us into SIP 2.00 anyway. Machines that want to log in using
|
||||
# telnet MUST send an SC Status message first, even though we're
|
||||
# not enforcing it.
|
||||
#
|
||||
#$expect = SC_STATUS;
|
||||
$expect = '';
|
||||
|
||||
while ($input = Sip::read_SIP_packet(*STDIN)) {
|
||||
my $status;
|
||||
|
||||
$input =~ s/[\r\n]+$//sm; # Strip off any trailing line ends
|
||||
|
||||
$status = Sip::MsgType::handle($input, $self, $expect);
|
||||
next if $status eq REQUEST_ACS_RESEND;
|
||||
|
||||
if (!$status) {
|
||||
syslog("LOG_ERR", "raw_transport: failed to handle %s",
|
||||
substr($input, 0, 2));
|
||||
die "raw_transport: dying";
|
||||
} elsif ($expect && ($status ne $expect)) {
|
||||
# We received a non-"RESEND" that wasn't what we were
|
||||
# expecting.
|
||||
syslog("LOG_ERR",
|
||||
"raw_transport: expected %s, received %s, exiting",
|
||||
$expect, $input);
|
||||
die "raw_transport: exiting: expected '$expect', received '$status'";
|
||||
}
|
||||
# We successfully received and processed what we were expecting
|
||||
# to receive
|
||||
$expect = '';
|
||||
}
|
||||
}
|
||||
|
|
@ -0,0 +1,55 @@
|
|||
<acsconfig xmlns="http://openncip.org/acs-config/1.0/">
|
||||
|
||||
<error-detect enabled="true" />
|
||||
|
||||
<!-- Set Net::Server::PreFork runtime parameters -->
|
||||
<!-- <server-params
|
||||
min_servers='1'
|
||||
min_spare_servers='0' /> -->
|
||||
|
||||
|
||||
<listeners>
|
||||
<service
|
||||
port="0:8080/tcp"
|
||||
transport="http"
|
||||
protocol="NCIP/1.0" />
|
||||
|
||||
<service
|
||||
port="8023/tcp"
|
||||
transport="telnet"
|
||||
protocol="SIP/1.00"
|
||||
timeout="60" />
|
||||
|
||||
<service
|
||||
port="127.0.0.1:6001/tcp"
|
||||
transport="RAW"
|
||||
protocol="SIP/2.00"
|
||||
timeout="60" />
|
||||
</listeners>
|
||||
|
||||
<accounts>
|
||||
<login id="koha" password="koha" institution="kohalibrary">
|
||||
</login>
|
||||
<login id="koha2" password="koha2" institution="kohalibrary" />
|
||||
<login id="lpl-sc" password="1234" institution="LPL" />
|
||||
<login id="lpl-sc-beacock" password="xyzzy"
|
||||
delimiter="|" error-detect="enabled" institution="LPL" />
|
||||
</accounts>
|
||||
|
||||
<!-- Institution tags will hold stuff used to interface to -->
|
||||
<!-- the rest of the ILS: authentication parameters, etc. I -->
|
||||
<!-- don't know what yet, so it'll just be blank. But there -->
|
||||
<!-- needs to be one institution stanza for each institution -->
|
||||
<!-- named in the accounts above. -->
|
||||
<institutions>
|
||||
<institution id="kohalibrary" implementation="ILS" parms="">
|
||||
<policy checkin="true" renewal="false"
|
||||
status_update="false" offline="false"
|
||||
timeout="600"
|
||||
retries="3" />
|
||||
</institution>
|
||||
|
||||
<institution id="LPL" implementation="ILS">
|
||||
</institution>
|
||||
</institutions>
|
||||
</acsconfig>
|
||||
|
|
@ -0,0 +1,188 @@
|
|||
#
|
||||
# Sip.pm: General Sip utility functions
|
||||
#
|
||||
|
||||
package Sip;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use English;
|
||||
use Exporter;
|
||||
|
||||
use Sys::Syslog qw(syslog);
|
||||
use POSIX qw(strftime);
|
||||
|
||||
use Sip::Constants qw(SIP_DATETIME);
|
||||
use Sip::Checksum qw(checksum);
|
||||
|
||||
our @ISA = qw(Exporter);
|
||||
|
||||
our @EXPORT_OK = qw(y_or_n timestamp add_field maybe_add add_count
|
||||
denied sipbool boolspace write_msg read_SIP_packet
|
||||
$error_detection $protocol_version $field_delimiter
|
||||
$last_response);
|
||||
|
||||
our %EXPORT_TAGS = (
|
||||
all => [qw(y_or_n timestamp add_field maybe_add
|
||||
add_count denied sipbool boolspace write_msg
|
||||
read_SIP_packet
|
||||
$error_detection $protocol_version
|
||||
$field_delimiter $last_response)]);
|
||||
|
||||
|
||||
our $error_detection = 0;
|
||||
our $protocol_version = 1;
|
||||
our $field_delimiter = '|'; # Protocol Default
|
||||
|
||||
# We need to keep a copy of the last message we sent to the SC,
|
||||
# in case there's a transmission error and the SC sends us a
|
||||
# REQUEST_ACS_RESEND. If we receive a REQUEST_ACS_RESEND before
|
||||
# we've ever sent anything, then we are to respond with a
|
||||
# REQUEST_SC_RESEND (p.16)
|
||||
|
||||
our $last_response = '';
|
||||
|
||||
sub timestamp {
|
||||
my $time = $_[0] || time();
|
||||
|
||||
return strftime(SIP_DATETIME, localtime($time));
|
||||
}
|
||||
|
||||
#
|
||||
# add_field(field_id, value)
|
||||
# return constructed field value
|
||||
#
|
||||
sub add_field {
|
||||
my ($field_id, $value) = @_;
|
||||
my ($i, $ent);
|
||||
|
||||
if (!defined($value)) {
|
||||
syslog("LOG_DEBUG", "add_field: Undefined value being added to '%s'",
|
||||
$field_id);
|
||||
$value = '';
|
||||
}
|
||||
|
||||
# Replace any occurences of the field delimiter in the
|
||||
# field value with the HTML character entity
|
||||
$ent = sprintf("&#%d;", ord($field_delimiter));
|
||||
|
||||
while (($i = index($value, $field_delimiter)) != ($[-1)) {
|
||||
substr($value, $i, 1) = $ent;
|
||||
}
|
||||
|
||||
return $field_id . $value . $field_delimiter;
|
||||
}
|
||||
#
|
||||
# maybe_add(field_id, value):
|
||||
# If value is defined and non-empty, then return the
|
||||
# constructed field value, otherwise return the empty string
|
||||
#
|
||||
sub maybe_add {
|
||||
my ($fid, $value) = @_;
|
||||
|
||||
return (defined($value) && $value) ? add_field($fid, $value) : '';
|
||||
}
|
||||
|
||||
#
|
||||
# add_count() produce fixed four-character count field,
|
||||
# or a string of four spaces if the count is invalid for some
|
||||
# reason
|
||||
#
|
||||
sub add_count {
|
||||
my ($label, $count) = @_;
|
||||
|
||||
# If the field is unsupported, it will be undef, return blanks
|
||||
# as per the spec.
|
||||
if (!defined($count)) {
|
||||
return ' ' x 4;
|
||||
}
|
||||
|
||||
$count = sprintf("%04d", $count);
|
||||
if (length($count) != 4) {
|
||||
syslog("LOG_WARNING", "handle_patron_info: %s wrong size: '%s'",
|
||||
$label, $count);
|
||||
$count = ' ' x 4;
|
||||
}
|
||||
return $count;
|
||||
}
|
||||
|
||||
#
|
||||
# denied($bool)
|
||||
# if $bool is false, return true. This is because SIP statuses
|
||||
# are inverted: we report that something has been denied, not that
|
||||
# it's permitted. For example, 'renewal priv. denied' of 'Y' means
|
||||
# that the user's not permitted to renew. I assume that the ILS has
|
||||
# real positive tests.
|
||||
#
|
||||
sub denied {
|
||||
my $bool = shift;
|
||||
|
||||
return boolspace(!$bool);
|
||||
}
|
||||
|
||||
sub sipbool {
|
||||
my $bool = shift;
|
||||
|
||||
return $bool ? 'Y' : 'N';
|
||||
}
|
||||
|
||||
#
|
||||
# boolspace: ' ' is false, 'Y' is true. (don't ask)
|
||||
#
|
||||
sub boolspace {
|
||||
my $bool = shift;
|
||||
|
||||
return $bool ? 'Y' : ' ';
|
||||
}
|
||||
|
||||
|
||||
# read_SIP_packet($file)
|
||||
#
|
||||
# Read a packet from $file, using the correct record separator
|
||||
#
|
||||
sub read_SIP_packet {
|
||||
my $file = shift;
|
||||
my $record;
|
||||
local $/ = "\r";
|
||||
|
||||
$record = readline($file);
|
||||
syslog("LOG_INFO", "INPUT MSG: '$record'") if $record;
|
||||
return $record;
|
||||
}
|
||||
|
||||
#
|
||||
# write_msg($msg, $file)
|
||||
#
|
||||
# Send $msg to the SC. If error detection is active, then
|
||||
# add the sequence number (if $seqno is non-zero) and checksum
|
||||
# to the message, and save the whole thing as $last_response
|
||||
#
|
||||
# If $file is set, then it's a file handle: write to it, otherwise
|
||||
# just write to the default destination.
|
||||
#
|
||||
|
||||
sub write_msg {
|
||||
my ($self, $msg, $file) = @_;
|
||||
my $cksum;
|
||||
|
||||
if ($error_detection) {
|
||||
if (defined($self->{seqno})) {
|
||||
$msg .= 'AY' . $self->{seqno};
|
||||
}
|
||||
$msg .= 'AZ';
|
||||
$cksum = checksum($msg);
|
||||
$msg .= sprintf('%04.4X', $cksum);
|
||||
}
|
||||
|
||||
|
||||
if ($file) {
|
||||
print $file "$msg\r";
|
||||
} else {
|
||||
print "$msg\r";
|
||||
syslog("LOG_INFO", "OUTPUT MSG: '$msg'");
|
||||
}
|
||||
|
||||
$last_response = $msg;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,55 @@
|
|||
package Sip::Checksum;
|
||||
|
||||
use Exporter;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT_OK = qw(checksum verify_cksum);
|
||||
|
||||
sub checksum {
|
||||
my $pkt = shift;
|
||||
|
||||
return (-unpack('%16U*', $pkt) & 0xFFFF);
|
||||
}
|
||||
|
||||
sub verify_cksum {
|
||||
my $pkt = shift;
|
||||
my $cksum;
|
||||
my $shortsum;
|
||||
|
||||
return 0 if (substr($pkt, -6, 2) ne "AZ"); # No checksum at end
|
||||
|
||||
# Convert the checksum back to hex and calculate the sum of the
|
||||
# pack without the checksum.
|
||||
$cksum = hex(substr($pkt, -4));
|
||||
$shortsum = unpack("%16U*", substr($pkt, 0, -4));
|
||||
|
||||
# The checksum is valid if the hex sum, plus the checksum of the
|
||||
# base packet short when truncated to 16 bits.
|
||||
return (($cksum + $shortsum) & 0xFFFF) == 0;
|
||||
}
|
||||
|
||||
{
|
||||
no warnings qw(once);
|
||||
eval join('',<main::DATA>) || die $@ unless caller();
|
||||
}
|
||||
__END__
|
||||
|
||||
#
|
||||
# Some simple test data
|
||||
#
|
||||
sub test {
|
||||
my $testpkt = shift;
|
||||
my $cksum = checksum($testpkt);
|
||||
my $fullpkt = sprintf("%s%4X", $testpkt, $cksum);
|
||||
|
||||
print $fullpkt, "\n";
|
||||
}
|
||||
|
||||
while (<>) {
|
||||
chomp;
|
||||
test($_);
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,105 @@
|
|||
#
|
||||
# parse-config: Parse an XML-format
|
||||
# ACS configuration file and build the configuration
|
||||
# structure.
|
||||
#
|
||||
|
||||
package Sip::Configuration;
|
||||
|
||||
use strict;
|
||||
use English;
|
||||
use warnings;
|
||||
use XML::Simple qw(:strict);
|
||||
|
||||
use Sip::Configuration::Institution;
|
||||
use Sip::Configuration::Account;
|
||||
use Sip::Configuration::Service;
|
||||
|
||||
my $parser = new XML::Simple( KeyAttr => { login => '+id',
|
||||
institution => '+id',
|
||||
service => '+port' },
|
||||
GroupTags => { listeners => 'service',
|
||||
accounts => 'login',
|
||||
institutions => 'institution', },
|
||||
ForceArray=> [ 'service',
|
||||
'login',
|
||||
'institution' ],
|
||||
ValueAttr => { 'error-detect' => 'enabled',
|
||||
'min_servers' => 'value',
|
||||
'max_servers' => 'value'} );
|
||||
|
||||
sub new {
|
||||
my ($class, $config_file) = @_;
|
||||
my $cfg = $parser->XMLin($config_file);
|
||||
my %listeners;
|
||||
|
||||
foreach my $acct (values %{$cfg->{accounts}}) {
|
||||
new Sip::Configuration::Account $acct;
|
||||
}
|
||||
|
||||
# The key to the listeners hash is the 'port' component of the
|
||||
# configuration, which is of the form '[host]:[port]/proto', and
|
||||
# the 'proto' component could be upper-, lower-, or mixed-cased.
|
||||
# Regularize it here to lower-case, and then do the same below in
|
||||
# find_server() when building the keys to search the hash.
|
||||
|
||||
foreach my $service (values %{$cfg->{listeners}}) {
|
||||
new Sip::Configuration::Service $service;
|
||||
$listeners{lc $service->{port}} = $service;
|
||||
}
|
||||
$cfg->{listeners} = \%listeners;
|
||||
|
||||
foreach my $inst (values %{$cfg->{institutions}}) {
|
||||
new Sip::Configuration::Institution $inst;
|
||||
}
|
||||
|
||||
return bless $cfg, $class;
|
||||
}
|
||||
|
||||
sub error_detect {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{'error-detect'};
|
||||
}
|
||||
|
||||
sub accounts {
|
||||
my $self = shift;
|
||||
|
||||
return values %{$self->{accounts}};
|
||||
}
|
||||
|
||||
sub find_service {
|
||||
my ($self, $sockaddr, $port, $proto) = @_;
|
||||
my $portstr;
|
||||
|
||||
foreach my $addr ('', '*:', "$sockaddr:") {
|
||||
$portstr = sprintf("%s%s/%s", $addr, $port, lc $proto);
|
||||
Sys::Syslog::syslog("LOG_DEBUG", "Configuration::find_service: Trying $portstr");
|
||||
last if (exists(($self->{listeners})->{$portstr}));
|
||||
}
|
||||
|
||||
return $self->{listeners}->{$portstr};
|
||||
}
|
||||
|
||||
#
|
||||
# Testing
|
||||
#
|
||||
|
||||
|
||||
{
|
||||
no warnings qw(once);
|
||||
eval join('',<main::DATA>) || die $@ unless caller();
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
my $config = new Sip::Configuration $ARGV[0];
|
||||
|
||||
|
||||
foreach my $acct ($config->accounts) {
|
||||
print "Found account '", $acct->name, "', part of '"
|
||||
print $acct->institution, "'\n";
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,43 @@
|
|||
#
|
||||
#
|
||||
#
|
||||
#
|
||||
|
||||
package Sip::Configuration::Account;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use English;
|
||||
use Exporter;
|
||||
|
||||
sub new {
|
||||
my ($class, $obj) = @_;
|
||||
my $type = ref($class) || $class;
|
||||
|
||||
if (ref($obj) eq "HASH") {
|
||||
# Just bless the object
|
||||
return bless $obj, $type;
|
||||
}
|
||||
|
||||
return bless {}, $type;
|
||||
}
|
||||
|
||||
sub id {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{id};
|
||||
}
|
||||
|
||||
sub institution {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{institution};
|
||||
}
|
||||
|
||||
sub password {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{password};
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,31 @@
|
|||
#
|
||||
#
|
||||
#
|
||||
#
|
||||
|
||||
package Sip::Configuration::Institution;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use English;
|
||||
use Exporter;
|
||||
|
||||
sub new {
|
||||
my ($class, $obj) = @_;
|
||||
my $type = ref($class) || $class;
|
||||
|
||||
if (ref($obj) eq "HASH") {
|
||||
# Just bless the object
|
||||
return bless $obj, $type;
|
||||
}
|
||||
|
||||
return bless {}, $type;
|
||||
}
|
||||
|
||||
sub name {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{name};
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
#
|
||||
#
|
||||
#
|
||||
#
|
||||
|
||||
package Sip::Configuration::Service;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use English;
|
||||
use Exporter;
|
||||
|
||||
sub new {
|
||||
my ($class, $obj) = @_;
|
||||
my $type = ref($class) || $class;
|
||||
|
||||
if (ref($obj) eq "HASH") {
|
||||
# Just bless the object
|
||||
return bless $obj, $type;
|
||||
}
|
||||
|
||||
return bless {}, $type;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,339 @@
|
|||
#
|
||||
# Sip::Constants.pm
|
||||
#
|
||||
# Various protocol constant values for 3M's Standard Interchange
|
||||
# Protocol for communication between a library's Automated
|
||||
# Checkout System (ACS) and stand-alone Self-Check (SC) units
|
||||
|
||||
package Sip::Constants;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Exporter;
|
||||
|
||||
our (@ISA, @EXPORT_OK, %EXPORT_TAGS);
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
|
||||
@EXPORT_OK = qw(PATRON_STATUS_REQ CHECKOUT CHECKIN BLOCK_PATRON
|
||||
SC_STATUS REQUEST_ACS_RESEND LOGIN PATRON_INFO
|
||||
END_PATRON_SESSION FEE_PAID ITEM_INFORMATION
|
||||
ITEM_STATUS_UPDATE PATRON_ENABLE HOLD RENEW
|
||||
RENEW_ALL PATRON_STATUS_RESP CHECKOUT_RESP
|
||||
CHECKIN_RESP ACS_STATUS REQUEST_SC_RESEND
|
||||
LOGIN_RESP PATRON_INFO_RESP END_SESSION_RESP
|
||||
FEE_PAID_RESP ITEM_INFO_RESP
|
||||
ITEM_STATUS_UPDATE_RESP PATRON_ENABLE_RESP
|
||||
HOLD_RESP RENEW_RESP RENEW_ALL_RESP
|
||||
REQUEST_ACS_RESEND_CKSUM REQUEST_SC_RESEND_CKSUM
|
||||
FID_PATRON_ID FID_ITEM_ID FID_TERMINAL_PWD
|
||||
FID_PATRON_PWD FID_PERSONAL_NAME FID_SCREEN_MSG
|
||||
FID_PRINT_LINE FID_DUE_DATE FID_TITLE_ID
|
||||
FID_BLOCKED_CARD_MSG FID_LIBRARY_NAME
|
||||
FID_TERMINAL_LOCN FID_INST_ID FID_CURRENT_LOCN
|
||||
FID_PERM_LOCN FID_HOLD_ITEMS FID_OVERDUE_ITEMS
|
||||
FID_CHARGED_ITEMS FID_FINE_ITEMS FID_SEQNO
|
||||
FID_CKSUM FID_HOME_ADDR FID_EMAIL FID_HOME_PHONE
|
||||
FID_OWNER FID_CURRENCY FID_CANCEL
|
||||
FID_TRANSACTION_ID FID_VALID_PATRON
|
||||
FID_RENEWED_ITEMS FID_UNRENEWED_ITEMS FID_FEE_ACK
|
||||
FID_START_ITEM FID_END_ITEM FID_QUEUE_POS
|
||||
FID_PICKUP_LOCN FID_FEE_TYPE FID_RECALL_ITEMS
|
||||
FID_FEE_AMT FID_EXPIRATION FID_SUPPORTED_MSGS
|
||||
FID_HOLD_TYPE FID_HOLD_ITEMS_LMT
|
||||
FID_OVERDUE_ITEMS_LMT FID_CHARGED_ITEMS_LMT
|
||||
FID_FEE_LMT FID_UNAVAILABLE_HOLD_ITEMS
|
||||
FID_HOLD_QUEUE_LEN FID_FEE_ID FID_ITEM_PROPS
|
||||
FID_SECURITY_INHIBIT FID_RECALL_DATE
|
||||
FID_MEDIA_TYPE FID_SORT_BIN FID_HOLD_PICKUP_DATE
|
||||
FID_LOGIN_UID FID_LOGIN_PWD FID_LOCATION_CODE
|
||||
FID_VALID_PATRON_PWD
|
||||
|
||||
FID_PATRON_BIRTHDATE FID_PATRON_CLASS FID_INET_PROFILE
|
||||
|
||||
SC_STATUS_OK SC_STATUS_PAPER SC_STATUS_SHUTDOWN
|
||||
SIP_DATETIME);
|
||||
|
||||
%EXPORT_TAGS = (
|
||||
|
||||
SC_msgs => [qw(PATRON_STATUS_REQ CHECKOUT CHECKIN
|
||||
BLOCK_PATRON SC_STATUS
|
||||
REQUEST_ACS_RESEND LOGIN
|
||||
PATRON_INFO
|
||||
END_PATRON_SESSION FEE_PAID
|
||||
ITEM_INFORMATION
|
||||
ITEM_STATUS_UPDATE
|
||||
PATRON_ENABLE HOLD RENEW
|
||||
RENEW_ALL)],
|
||||
|
||||
ACS_msgs => [qw(PATRON_STATUS_RESP CHECKOUT_RESP
|
||||
CHECKIN_RESP ACS_STATUS
|
||||
REQUEST_SC_RESEND LOGIN_RESP
|
||||
PATRON_INFO_RESP
|
||||
END_SESSION_RESP
|
||||
FEE_PAID_RESP ITEM_INFO_RESP
|
||||
ITEM_STATUS_UPDATE_RESP
|
||||
PATRON_ENABLE_RESP HOLD_RESP
|
||||
RENEW_RESP RENEW_ALL_RESP)],
|
||||
|
||||
constant_msgs => [qw(REQUEST_ACS_RESEND_CKSUM
|
||||
REQUEST_SC_RESEND_CKSUM)],
|
||||
|
||||
field_ids => [qw( FID_PATRON_ID FID_ITEM_ID
|
||||
FID_TERMINAL_PWD
|
||||
FID_PATRON_PWD
|
||||
FID_PERSONAL_NAME
|
||||
FID_SCREEN_MSG
|
||||
FID_PRINT_LINE FID_DUE_DATE
|
||||
FID_TITLE_ID
|
||||
FID_BLOCKED_CARD_MSG
|
||||
FID_LIBRARY_NAME
|
||||
FID_TERMINAL_LOCN
|
||||
FID_INST_ID
|
||||
FID_CURRENT_LOCN
|
||||
FID_PERM_LOCN
|
||||
FID_HOLD_ITEMS
|
||||
FID_OVERDUE_ITEMS
|
||||
FID_CHARGED_ITEMS
|
||||
FID_FINE_ITEMS FID_SEQNO
|
||||
FID_CKSUM FID_HOME_ADDR
|
||||
FID_EMAIL FID_HOME_PHONE
|
||||
FID_OWNER FID_CURRENCY
|
||||
FID_CANCEL
|
||||
FID_TRANSACTION_ID
|
||||
FID_VALID_PATRON
|
||||
FID_RENEWED_ITEMS
|
||||
FID_UNRENEWED_ITEMS
|
||||
FID_FEE_ACK FID_START_ITEM
|
||||
FID_END_ITEM FID_QUEUE_POS
|
||||
FID_PICKUP_LOCN
|
||||
FID_FEE_TYPE
|
||||
FID_RECALL_ITEMS
|
||||
FID_FEE_AMT FID_EXPIRATION
|
||||
FID_SUPPORTED_MSGS
|
||||
FID_HOLD_TYPE
|
||||
FID_HOLD_ITEMS_LMT
|
||||
FID_OVERDUE_ITEMS_LMT
|
||||
FID_CHARGED_ITEMS_LMT
|
||||
FID_FEE_LMT
|
||||
FID_UNAVAILABLE_HOLD_ITEMS
|
||||
FID_HOLD_QUEUE_LEN
|
||||
FID_FEE_ID FID_ITEM_PROPS
|
||||
FID_SECURITY_INHIBIT
|
||||
FID_RECALL_DATE
|
||||
FID_MEDIA_TYPE FID_SORT_BIN
|
||||
FID_HOLD_PICKUP_DATE
|
||||
FID_LOGIN_UID FID_LOGIN_PWD
|
||||
FID_LOCATION_CODE
|
||||
FID_VALID_PATRON_PWD
|
||||
|
||||
FID_PATRON_BIRTHDATE
|
||||
FID_PATRON_CLASS
|
||||
FID_INET_PROFILE)],
|
||||
|
||||
SC_status => [qw(SC_STATUS_OK SC_STATUS_PAPER
|
||||
SC_STATUS_SHUTDOWN)],
|
||||
|
||||
formats => [qw(SIP_DATETIME)],
|
||||
|
||||
all => [qw(PATRON_STATUS_REQ CHECKOUT CHECKIN
|
||||
BLOCK_PATRON SC_STATUS
|
||||
REQUEST_ACS_RESEND LOGIN PATRON_INFO
|
||||
END_PATRON_SESSION FEE_PAID
|
||||
ITEM_INFORMATION ITEM_STATUS_UPDATE
|
||||
PATRON_ENABLE HOLD RENEW RENEW_ALL
|
||||
PATRON_STATUS_RESP CHECKOUT_RESP
|
||||
CHECKIN_RESP ACS_STATUS
|
||||
REQUEST_SC_RESEND LOGIN_RESP
|
||||
PATRON_INFO_RESP END_SESSION_RESP
|
||||
FEE_PAID_RESP ITEM_INFO_RESP
|
||||
ITEM_STATUS_UPDATE_RESP
|
||||
PATRON_ENABLE_RESP HOLD_RESP
|
||||
RENEW_RESP RENEW_ALL_RESP
|
||||
REQUEST_ACS_RESEND_CKSUM
|
||||
REQUEST_SC_RESEND_CKSUM FID_PATRON_ID
|
||||
FID_ITEM_ID FID_TERMINAL_PWD
|
||||
FID_PATRON_PWD FID_PERSONAL_NAME
|
||||
FID_SCREEN_MSG FID_PRINT_LINE
|
||||
FID_DUE_DATE FID_TITLE_ID
|
||||
FID_BLOCKED_CARD_MSG FID_LIBRARY_NAME
|
||||
FID_TERMINAL_LOCN FID_INST_ID
|
||||
FID_CURRENT_LOCN FID_PERM_LOCN
|
||||
FID_HOLD_ITEMS FID_OVERDUE_ITEMS
|
||||
FID_CHARGED_ITEMS FID_FINE_ITEMS
|
||||
FID_SEQNO FID_CKSUM FID_HOME_ADDR
|
||||
FID_EMAIL FID_HOME_PHONE FID_OWNER
|
||||
FID_CURRENCY FID_CANCEL
|
||||
FID_TRANSACTION_ID FID_VALID_PATRON
|
||||
FID_RENEWED_ITEMS FID_UNRENEWED_ITEMS
|
||||
FID_FEE_ACK FID_START_ITEM
|
||||
FID_END_ITEM FID_QUEUE_POS
|
||||
FID_PICKUP_LOCN FID_FEE_TYPE
|
||||
FID_RECALL_ITEMS FID_FEE_AMT
|
||||
FID_EXPIRATION FID_SUPPORTED_MSGS
|
||||
FID_HOLD_TYPE FID_HOLD_ITEMS_LMT
|
||||
FID_OVERDUE_ITEMS_LMT
|
||||
FID_CHARGED_ITEMS_LMT FID_FEE_LMT
|
||||
FID_UNAVAILABLE_HOLD_ITEMS
|
||||
FID_HOLD_QUEUE_LEN FID_FEE_ID
|
||||
FID_ITEM_PROPS FID_SECURITY_INHIBIT
|
||||
FID_RECALL_DATE FID_MEDIA_TYPE
|
||||
FID_SORT_BIN FID_HOLD_PICKUP_DATE
|
||||
FID_LOGIN_UID FID_LOGIN_PWD
|
||||
FID_LOCATION_CODE FID_VALID_PATRON_PWD
|
||||
FID_PATRON_BIRTHDATE FID_PATRON_CLASS
|
||||
FID_INET_PROFILE
|
||||
SC_STATUS_OK SC_STATUS_PAPER SC_STATUS_SHUTDOWN
|
||||
SIP_DATETIME
|
||||
)]);
|
||||
|
||||
#
|
||||
# Declare message types
|
||||
#
|
||||
|
||||
# Messages from SC to ACS
|
||||
use constant {
|
||||
PATRON_STATUS_REQ => '23',
|
||||
CHECKOUT => '11',
|
||||
CHECKIN => '09',
|
||||
BLOCK_PATRON => '01',
|
||||
SC_STATUS => '99',
|
||||
REQUEST_ACS_RESEND => '97',
|
||||
LOGIN => '93',
|
||||
PATRON_INFO => '63',
|
||||
END_PATRON_SESSION => '35',
|
||||
FEE_PAID => '37',
|
||||
ITEM_INFORMATION => '17',
|
||||
ITEM_STATUS_UPDATE => '19',
|
||||
PATRON_ENABLE => '25',
|
||||
HOLD => '15',
|
||||
RENEW => '29',
|
||||
RENEW_ALL => '65',
|
||||
};
|
||||
|
||||
# Message responses from ACS to SC
|
||||
use constant {
|
||||
PATRON_STATUS_RESP => '24',
|
||||
CHECKOUT_RESP => '12',
|
||||
CHECKIN_RESP => '10',
|
||||
ACS_STATUS => '98',
|
||||
REQUEST_SC_RESEND => '96',
|
||||
LOGIN_RESP => '94',
|
||||
PATRON_INFO_RESP => '64',
|
||||
END_SESSION_RESP => '36',
|
||||
FEE_PAID_RESP => '38',
|
||||
ITEM_INFO_RESP => '18',
|
||||
ITEM_STATUS_UPDATE_RESP => '20',
|
||||
PATRON_ENABLE_RESP => '26',
|
||||
HOLD_RESP => '16',
|
||||
RENEW_RESP => '30',
|
||||
RENEW_ALL_RESP => '66',
|
||||
};
|
||||
|
||||
#
|
||||
# Some messages are short and invariant, so they're constant's too
|
||||
#
|
||||
use constant {
|
||||
REQUEST_ACS_RESEND_CKSUM => '97AZFEF5',
|
||||
REQUEST_SC_RESEND_CKSUM => '96AZFEF6',
|
||||
};
|
||||
|
||||
#
|
||||
# Field Identifiers
|
||||
#
|
||||
use constant {
|
||||
FID_PATRON_ID => 'AA',
|
||||
FID_ITEM_ID => 'AB',
|
||||
FID_TERMINAL_PWD => 'AC',
|
||||
FID_PATRON_PWD => 'AD',
|
||||
FID_PERSONAL_NAME => 'AE',
|
||||
FID_SCREEN_MSG => 'AF',
|
||||
FID_PRINT_LINE => 'AG',
|
||||
FID_DUE_DATE => 'AH',
|
||||
# UNUSED AI
|
||||
FID_TITLE_ID => 'AJ',
|
||||
# UNUSED AK
|
||||
FID_BLOCKED_CARD_MSG => 'AL',
|
||||
FID_LIBRARY_NAME => 'AM',
|
||||
FID_TERMINAL_LOCN => 'AN',
|
||||
FID_INST_ID => 'AO',
|
||||
FID_CURRENT_LOCN => 'AP',
|
||||
FID_PERM_LOCN => 'AQ',
|
||||
# UNUSED AR
|
||||
FID_HOLD_ITEMS => 'AS', # SIP 2.0
|
||||
FID_OVERDUE_ITEMS => 'AT', # SIP 2.0
|
||||
FID_CHARGED_ITEMS => 'AU', # SIP 2.0
|
||||
FID_FINE_ITEMS => 'AV', # SIP 2.0
|
||||
# UNUSED AW
|
||||
# UNUSED AX
|
||||
FID_SEQNO => 'AY',
|
||||
FID_CKSUM => 'AZ',
|
||||
|
||||
# SIP 2.0 Fields
|
||||
# UNUSED BA
|
||||
# UNUSED BB
|
||||
# UNUSED BC
|
||||
FID_HOME_ADDR => 'BD',
|
||||
FID_EMAIL => 'BE',
|
||||
FID_HOME_PHONE => 'BF',
|
||||
FID_OWNER => 'BG',
|
||||
FID_CURRENCY => 'BH',
|
||||
FID_CANCEL => 'BI',
|
||||
# UNUSED BJ
|
||||
FID_TRANSACTION_ID => 'BK',
|
||||
FID_VALID_PATRON => 'BL',
|
||||
FID_RENEWED_ITEMS => 'BM',
|
||||
FID_UNRENEWED_ITEMS => 'BN',
|
||||
FID_FEE_ACK => 'BO',
|
||||
FID_START_ITEM => 'BP',
|
||||
FID_END_ITEM => 'BQ',
|
||||
FID_QUEUE_POS => 'BR',
|
||||
FID_PICKUP_LOCN => 'BS',
|
||||
FID_FEE_TYPE => 'BT',
|
||||
FID_RECALL_ITEMS => 'BU',
|
||||
FID_FEE_AMT => 'BV',
|
||||
FID_EXPIRATION => 'BW',
|
||||
FID_SUPPORTED_MSGS => 'BX',
|
||||
FID_HOLD_TYPE => 'BY',
|
||||
FID_HOLD_ITEMS_LMT => 'BZ',
|
||||
FID_OVERDUE_ITEMS_LMT => 'CA',
|
||||
FID_CHARGED_ITEMS_LMT => 'CB',
|
||||
FID_FEE_LMT => 'CC',
|
||||
FID_UNAVAILABLE_HOLD_ITEMS => 'CD',
|
||||
# UNUSED CE
|
||||
FID_HOLD_QUEUE_LEN => 'CF',
|
||||
FID_FEE_ID => 'CG',
|
||||
FID_ITEM_PROPS => 'CH',
|
||||
FID_SECURITY_INHIBIT => 'CI',
|
||||
FID_RECALL_DATE => 'CJ',
|
||||
FID_MEDIA_TYPE => 'CK',
|
||||
FID_SORT_BIN => 'CL',
|
||||
FID_HOLD_PICKUP_DATE => 'CM',
|
||||
FID_LOGIN_UID => 'CN',
|
||||
FID_LOGIN_PWD => 'CO',
|
||||
FID_LOCATION_CODE => 'CP',
|
||||
FID_VALID_PATRON_PWD => 'CQ',
|
||||
|
||||
# SIP Extensions used by Envisionware Terminals
|
||||
FID_PATRON_BIRTHDATE => 'PB',
|
||||
FID_PATRON_CLASS => 'PC',
|
||||
|
||||
# SIP Extension for reporting patron internet privileges
|
||||
FID_INET_PROFILE => 'PI',
|
||||
};
|
||||
|
||||
#
|
||||
# SC Status Codes
|
||||
#
|
||||
use constant {
|
||||
SC_STATUS_OK => '0',
|
||||
SC_STATUS_PAPER => '1',
|
||||
SC_STATUS_SHUTDOWN => '2',
|
||||
};
|
||||
|
||||
#
|
||||
# Various format strings
|
||||
#
|
||||
use constant {
|
||||
SIP_DATETIME => "%Y%m%d %H%M%S",
|
||||
};
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,42 @@
|
|||
import operator
|
||||
import socket
|
||||
from time import strftime;
|
||||
|
||||
def SipSocket(host='localhost', port=5300):
|
||||
so = socket.socket()
|
||||
so.connect((host, port))
|
||||
return so
|
||||
|
||||
def login(so, uname='scclient', passwd='clientpwd', locn='The basement',
|
||||
seqno=0):
|
||||
port = so.getpeername()[1]
|
||||
if port == 5300:
|
||||
resp = send(so, '9300CN%s|CO%s|CP%s|' % (uname, passwd, locn), seqno)
|
||||
print "Received", repr(resp)
|
||||
print "Verified: ", verify(resp)
|
||||
else:
|
||||
raise "Logging in is only support for the raw transport on port 5300"
|
||||
|
||||
def send(so, msg, seqno=0):
|
||||
if seqno:
|
||||
msg += 'AY' + str(seqno)[0] + 'AZ'
|
||||
msg += ('%04X' % calculate_cksum(msg))
|
||||
msg += '\r'
|
||||
print 'Sending', repr(msg)
|
||||
so.send(msg)
|
||||
resp = so.recv(1000)
|
||||
return resp, verify(resp)
|
||||
|
||||
def calculate_cksum(msg):
|
||||
return (-reduce(operator.add, map(ord, msg)) & 0xFFFF)
|
||||
|
||||
def sipdate():
|
||||
return(strftime("%Y%m%d %H%M%S"))
|
||||
|
||||
def verify(msg):
|
||||
if msg[-1] == '\r': msg = msg[:-2]
|
||||
if msg[-6:-4] == 'AZ':
|
||||
cksum = calculate_cksum(msg[:-4])
|
||||
return (msg[-4:] == ('%04X' % cksum))
|
||||
# If there's no checksum, then the message is ok
|
||||
return True
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
#!/usr/bin/perl
|
||||
#
|
||||
# sc_status: test basic connection, login, and response
|
||||
# to the SC Status message, which has to be sent before
|
||||
# anything else
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use SIPtest qw($datepat $username $password $login_test $sc_status_test);
|
||||
|
||||
my $invalid_uname = { id => 'Invalid username',
|
||||
msg => "9300CNinvalid$username|CO$password|CPThe floor|",
|
||||
pat => qr/^940/,
|
||||
fields => [], };
|
||||
|
||||
my $invalid_pwd = { id => 'Invalid username',
|
||||
msg => "9300CN$username|COinvalid$password|CPThe floor|",
|
||||
pat => qr/^940/,
|
||||
fields => [], };
|
||||
|
||||
my @tests = ( $invalid_uname, $invalid_pwd, $login_test, $sc_status_test );
|
||||
|
||||
SIPtest::run_sip_tests(@tests);
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,80 @@
|
|||
#!/usr/bin/perl
|
||||
#
|
||||
# patron_status: check status of valid patron and invalid patron
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Sip::Constants qw(:all);
|
||||
use SIPtest qw($datepat $instid $currency $user_barcode $user_pin
|
||||
$user_fullname $user_homeaddr $user_email $user_phone
|
||||
$user_birthday);
|
||||
|
||||
my @tests = (
|
||||
$SIPtest::login_test,
|
||||
$SIPtest::sc_status_test,
|
||||
{ id => 'valid Patron Status',
|
||||
msg => "2300120060101 084237AO$SIPtest::instid|AA$user_barcode|AD$user_pin|AC|",
|
||||
pat => qr/^24 [ Y]{13}\d{3}$datepat/,
|
||||
fields => [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_PERSONAL_NAME,
|
||||
pat => qr/^$user_fullname$/o,
|
||||
required => 1, },
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^$user_barcode/o,
|
||||
required => 1, },
|
||||
{ field => FID_VALID_PATRON,
|
||||
pat => qr/^Y$/,
|
||||
required => 0, },
|
||||
{ field => FID_VALID_PATRON_PWD,
|
||||
pat => qr/^Y$/,
|
||||
required => 0, },
|
||||
{ field => FID_CURRENCY,
|
||||
pat => qr/^$currency$/io,
|
||||
required => 0, },
|
||||
{ field => FID_FEE_AMT,
|
||||
pat => qr/^[0-9.]+$/,
|
||||
required => 0, },
|
||||
], },
|
||||
{ id => 'invalid password Patron Status',
|
||||
msg => "2300120060101 084237AO$instid|AA$user_barcode|AC|ADbadw|",
|
||||
pat => qr/^24[ Y]{14}\d{3}$datepat/,
|
||||
fields => [
|
||||
{ field => FID_PERSONAL_NAME,
|
||||
pat => qr/^$user_fullname$/o,
|
||||
required => 1, },
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^$user_barcode$/o,
|
||||
required => 1, },
|
||||
{ field => FID_INST_ID,
|
||||
pat => qr/^$instid$/o,
|
||||
required => 1, },
|
||||
{ field => FID_VALID_PATRON_PWD,
|
||||
pat => qr/^N$/,
|
||||
required => 1, },
|
||||
{ field => FID_VALID_PATRON,
|
||||
pat => qr/^Y$/,
|
||||
required => 1, },
|
||||
], },
|
||||
{ id => 'invalid Patron Status',
|
||||
msg => "2300120060101 084237AO$instid|AAwshakespeare|AC|",
|
||||
pat => qr/^24Y[ Y]{13}\d{3}$datepat/,
|
||||
fields => [
|
||||
{ field => FID_PERSONAL_NAME,
|
||||
pat => qr/^$/,
|
||||
required => 1, },
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^wshakespeare$/,
|
||||
required => 1, },
|
||||
{ field => FID_INST_ID,
|
||||
pat => qr/^$instid$/o,
|
||||
required => 1, },
|
||||
], },
|
||||
);
|
||||
|
||||
SIPtest::run_sip_tests(@tests);
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,172 @@
|
|||
#!/usr/bin/perl
|
||||
# patron_info: test Patron Information Response
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Clone qw(clone);
|
||||
|
||||
use Sip::Constants qw(:all);
|
||||
|
||||
use SIPtest qw($datepat $textpat $instid $currency $user_barcode $user_pin
|
||||
$user_fullname $user_homeaddr $user_email $user_phone
|
||||
$user_birthday $user_ptype $user_inet);
|
||||
|
||||
# This is a template test case for the Patron Information
|
||||
# message handling. Because of the large number of fields,
|
||||
# this template forms the basis for all of the different
|
||||
# situations: valid patron no details, valid patron with each
|
||||
# individual detail requested, invalid patron, invalid patron
|
||||
# password, etc.
|
||||
my $patron_info_test_template = {
|
||||
id => 'valid Patron Info no details',
|
||||
msg => "6300020060329 201700 AO$instid|AA$user_barcode|",
|
||||
pat => qr/^64 [ Y]{13}\d{3}$datepat(\d{4}){6}/,
|
||||
fields => [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^$user_barcode$/o,
|
||||
required => 1, },
|
||||
{ field => FID_PERSONAL_NAME,
|
||||
pat => qr/^$user_fullname$/o,
|
||||
required => 1, },
|
||||
$SIPtest::field_specs{(FID_HOLD_ITEMS_LMT)},
|
||||
$SIPtest::field_specs{(FID_OVERDUE_ITEMS_LMT)},
|
||||
$SIPtest::field_specs{(FID_CHARGED_ITEMS_LMT)},
|
||||
{ field => FID_VALID_PATRON,
|
||||
pat => qr/^Y$/,
|
||||
# Not required by the spec, but by the test
|
||||
required => 1, },
|
||||
$SIPtest::field_specs{(FID_CURRENCY)},
|
||||
{ field => FID_FEE_AMT,
|
||||
pat => $textpat,
|
||||
required => 0, },
|
||||
{ field => FID_FEE_LMT,
|
||||
pat => $textpat,
|
||||
required => 0, },
|
||||
{ field => FID_HOME_ADDR,
|
||||
pat => qr/^$user_homeaddr$/o,
|
||||
required => 1, }, # required by this test case
|
||||
{ field => FID_EMAIL,
|
||||
pat => qr/^$user_email$/o,
|
||||
required => 1, },
|
||||
{ field => FID_HOME_PHONE,
|
||||
pat => qr/^$user_phone$/o,
|
||||
required => 1, },
|
||||
{ field => FID_PATRON_BIRTHDATE,
|
||||
pat => qr/^$user_birthday$/o,
|
||||
required => 1, },
|
||||
{ field => FID_PATRON_CLASS,
|
||||
pat => qr/^$user_ptype$/o,
|
||||
required => 1, },
|
||||
{ field => FID_INET_PROFILE,
|
||||
pat => qr/^$user_inet$/,
|
||||
required => 1, },
|
||||
], };
|
||||
|
||||
my @tests = (
|
||||
$SIPtest::login_test,
|
||||
$SIPtest::sc_status_test,
|
||||
clone($patron_info_test_template),
|
||||
);
|
||||
|
||||
|
||||
# Create the test cases for the various summary detail fields
|
||||
sub create_patron_summary_tests {
|
||||
my $test;
|
||||
my @patron_info_summary_tests = (
|
||||
{ field => FID_HOLD_ITEMS,
|
||||
pat => $textpat,
|
||||
required => 0, },
|
||||
{ field => FID_OVERDUE_ITEMS,
|
||||
pat => $textpat,
|
||||
required => 0, },
|
||||
{ field => FID_CHARGED_ITEMS,
|
||||
pat => $textpat,
|
||||
required => 0, },
|
||||
# The test user has no items of these types, so the tests seem to fail
|
||||
# { field => FID_FINE_ITEMS,
|
||||
# pat => $textpat,
|
||||
# required => 1, },
|
||||
# { field => FID_RECALL_ITEMS,
|
||||
# pat => $textpat,
|
||||
# required => 0, },
|
||||
# { field => FID_UNAVAILABLE_HOLD_ITEMS,
|
||||
# pat => $textpat,
|
||||
# required => 0, },
|
||||
);
|
||||
|
||||
foreach my $i (0 .. scalar @patron_info_summary_tests-1) {
|
||||
# The tests for each of the summary fields are exactly the
|
||||
# same as the basic one, except for the fact that there's
|
||||
# an extra field to test
|
||||
|
||||
# Copy the hash, adjust it, add it to the end of the list
|
||||
$test = clone($patron_info_test_template);
|
||||
|
||||
substr($test->{msg}, 23+$i, 1) = 'Y';
|
||||
$test->{id} = "valid Patron Info details: "
|
||||
. $patron_info_summary_tests[$i]->{field};
|
||||
push @{$test->{fields}}, $patron_info_summary_tests[$i];
|
||||
push @tests, $test;
|
||||
}
|
||||
}
|
||||
|
||||
sub create_invalid_patron_tests {
|
||||
my $test;
|
||||
|
||||
$test = clone($patron_info_test_template);
|
||||
$test->{id} = "invalid Patron Info id";
|
||||
$test->{msg} =~ s/AA$user_barcode\|/AAberick|/o;
|
||||
$test->{pat} = qr/^64Y[ Y]{13}\d{3}$datepat(\d{4}){6}/;
|
||||
delete $test->{fields};
|
||||
$test->{fields} = [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^berick$/,
|
||||
required => 1, },
|
||||
{ field => FID_PERSONAL_NAME,
|
||||
pat => qr/^$/,
|
||||
required => 1, },
|
||||
{ field => FID_VALID_PATRON,
|
||||
pat => qr/^N$/,
|
||||
required => 1, },
|
||||
];
|
||||
push @tests, $test;
|
||||
|
||||
# Valid patron, invalid patron password
|
||||
$test = clone($patron_info_test_template);
|
||||
$test->{id} = "valid Patron Info, invalid password";
|
||||
$test->{msg} .= (FID_PATRON_PWD) . 'badpwd|';
|
||||
$test->{pat} = qr/^64[ Y]{14}\d{3}$datepat(\d{4}){6}/;
|
||||
delete $test->{fields};
|
||||
$test->{fields} = [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^$user_barcode$/,
|
||||
required => 1, },
|
||||
{ field => FID_PERSONAL_NAME,
|
||||
pat => qr/^$user_fullname$/,
|
||||
required => 1, },
|
||||
{ field => FID_VALID_PATRON,
|
||||
pat => qr/^Y$/,
|
||||
required => 1, },
|
||||
{ field => FID_VALID_PATRON_PWD,
|
||||
pat => qr/^N$/,
|
||||
required => 1, },
|
||||
];
|
||||
push @tests, $test;
|
||||
}
|
||||
|
||||
create_patron_summary_tests;
|
||||
|
||||
create_invalid_patron_tests;
|
||||
|
||||
SIPtest::run_sip_tests(@tests);
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,209 @@
|
|||
#!/usr/bin/perl
|
||||
# checkout: test Checkout Response
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Clone qw(clone);
|
||||
|
||||
use Sip::Constants qw(:all);
|
||||
|
||||
use SIPtest qw($datepat $textpat $instid $currency $user_barcode
|
||||
$item_barcode $item_title
|
||||
$item_diacritic_barcode $item_diacritic_title
|
||||
$item_diacritic_owner);
|
||||
|
||||
my $patron_enable_template = {
|
||||
id => 'Renew All: prep: enable patron permissions',
|
||||
msg => "2520060102 084238AO$instid|AA$user_barcode|",
|
||||
pat => qr/^26 {4}[ Y]{10}000$datepat/o,
|
||||
fields => [],
|
||||
};
|
||||
|
||||
my $patron_disable_template = {
|
||||
id => 'Checkout: block patron (prep to test checkout denied)',
|
||||
msg => "01N20060102 084238AO$instid|ALHe's a jerk|AA$user_barcode|",
|
||||
# response to block patron is a patron status message
|
||||
pat => qr/^24Y{4}[ Y]{10}000$datepat/o,
|
||||
fields => [], };
|
||||
|
||||
my $checkin_template = {
|
||||
id => 'Checkout: cleanup: check in item',
|
||||
msg => "09N20050102 08423620060113 084235APUnder the bed|AO$instid|AB$item_barcode|ACterminal password|",
|
||||
pat => qr/^101YNN$datepat/o,
|
||||
fields => [],
|
||||
};
|
||||
|
||||
my $checkout_test_template = {
|
||||
id => 'Checkout: valid item, valid patron',
|
||||
msg => "11YN20060329 203000 AO$instid|AA$user_barcode|AB$item_barcode|AC|",
|
||||
pat => qr/^121NNY$datepat/,
|
||||
fields => [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^$user_barcode$/o,
|
||||
required => 1, },
|
||||
{ field => FID_ITEM_ID,
|
||||
pat => qr/^$item_barcode$/o,
|
||||
required => 1, },
|
||||
{ field => FID_TITLE_ID,
|
||||
pat => qr/^$item_title\s*$/o,
|
||||
required => 1, },
|
||||
{ field => FID_DUE_DATE,
|
||||
pat => $textpat,
|
||||
required => 1, },
|
||||
{ field => FID_FEE_TYPE,
|
||||
pat => qr/^\d{2}$/,
|
||||
required => 0, },
|
||||
{ field => FID_SECURITY_INHIBIT,
|
||||
pat => qr/^[YN]$/,
|
||||
required => 0, },
|
||||
{ field => FID_CURRENCY,
|
||||
pat => qr/^$currency$/o,
|
||||
required => 0, },
|
||||
{ field => FID_FEE_AMT,
|
||||
pat => qr/^[.0-9]+$/,
|
||||
required => 0, },
|
||||
{ field => FID_MEDIA_TYPE,
|
||||
pat => qr/^\d{3}$/,
|
||||
required => 0, },
|
||||
{ field => FID_ITEM_PROPS,
|
||||
pat => $textpat,
|
||||
required => 0, },
|
||||
{ field => FID_TRANSACTION_ID,
|
||||
pat => $textpat,
|
||||
required => 0, },
|
||||
], };
|
||||
|
||||
my @tests = (
|
||||
$SIPtest::login_test,
|
||||
$SIPtest::sc_status_test,
|
||||
clone($checkout_test_template),
|
||||
# Don't check the item in, because we're about to test renew
|
||||
);
|
||||
|
||||
my $test;
|
||||
|
||||
## Renewal OK
|
||||
## Test this by checking out exactly the same book a second time.
|
||||
## The only difference should be that the "Renewal OK" flag should now
|
||||
## be 'Y'.
|
||||
#$test = clone($checkout_test_template);
|
||||
#$test->{id} = 'Checkout: patron renewal';
|
||||
#$test->{pat} = qr/^121YNY$datepat/;
|
||||
#
|
||||
#push @tests, $test;
|
||||
|
||||
# NOW check it in
|
||||
|
||||
push @tests, $checkin_template;
|
||||
|
||||
# Valid Patron, item with diacritical in the title
|
||||
$test = clone($checkout_test_template);
|
||||
|
||||
$test->{id} = 'Checkout: valid patron, diacritical character in title';
|
||||
$test->{msg} =~ s/AB$item_barcode/AB$item_diacritic_barcode/;
|
||||
|
||||
foreach my $i (0 .. (scalar @{$test->{fields}})-1) {
|
||||
my $field = $test->{fields}[$i];
|
||||
|
||||
if ($field->{field} eq FID_ITEM_ID) {
|
||||
$field->{pat} = qr/^$item_diacritic_barcode$/;
|
||||
} elsif ($field->{field} eq FID_TITLE_ID) {
|
||||
$field->{pat} = qr/^$item_diacritic_title\s*$/;
|
||||
} elsif ($field->{field} eq FID_OWNER) {
|
||||
$field->{pat} = qr/^$item_diacritic_owner$/;
|
||||
}
|
||||
}
|
||||
|
||||
push @tests, $test;
|
||||
|
||||
$test = clone($checkin_template);
|
||||
$test->{msg} =~ s/AB$item_barcode/AB$item_diacritic_barcode/;
|
||||
push @tests, $test;
|
||||
|
||||
# Valid Patron, Invalid Item_id
|
||||
$test = clone($checkout_test_template);
|
||||
|
||||
$test->{id} = 'Checkout: valid patron, invalid item';
|
||||
$test->{msg} =~ s/AB$item_barcode/ABno-barcode/o;
|
||||
$test->{pat} = qr/^120NUN$datepat/;
|
||||
delete $test->{fields};
|
||||
$test->{fields} = [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^$user_barcode$/o,
|
||||
required => 1, },
|
||||
{ field => FID_ITEM_ID,
|
||||
pat => qr/^no-barcode$/,
|
||||
required => 1, },
|
||||
{ field => FID_TITLE_ID,
|
||||
pat => qr/^$/,
|
||||
required => 1, },
|
||||
{ field => FID_DUE_DATE,
|
||||
pat => qr/^$/,
|
||||
required => 1, },
|
||||
{ field => FID_VALID_PATRON,
|
||||
pat => qr/^Y$/,
|
||||
required => 1, },
|
||||
];
|
||||
|
||||
push @tests, $test;
|
||||
|
||||
# Invalid patron, valid item
|
||||
$test = clone($checkout_test_template);
|
||||
$test->{id} = 'Checkout: invalid patron, valid item';
|
||||
$test->{msg} =~ s/AA$user_barcode/AAberick/;
|
||||
$test->{pat} = qr/^120NUN$datepat/;
|
||||
delete $test->{fields};
|
||||
$test->{fields} = [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^berick$/,
|
||||
required => 1, },
|
||||
{ field => FID_ITEM_ID,
|
||||
pat => qr/^$item_barcode$/o,
|
||||
required => 1, },
|
||||
{ field => FID_TITLE_ID,
|
||||
pat => qr/^$item_title\s*$/o,
|
||||
required => 1, },
|
||||
{ field => FID_DUE_DATE,
|
||||
pat => qr/^$/,
|
||||
required => 1, },
|
||||
{ field => FID_VALID_PATRON,
|
||||
pat => qr/^N$/,
|
||||
required => 1, },
|
||||
];
|
||||
|
||||
push @tests, $test;
|
||||
|
||||
# Needed: tests for blocked patrons, patrons with excessive
|
||||
# fines/fees, magnetic media, charging fees to borrow items.
|
||||
|
||||
## Blocked patron
|
||||
#$test = clone($checkout_test_template);
|
||||
#$test->{id} = 'Checkout: Blocked patron';
|
||||
#$test->{pat} = qr/^120NUN$datepat/;
|
||||
#delete $test->{fields};
|
||||
#$test->{fields} = [
|
||||
# $SIPtest::field_specs{(FID_INST_ID)},
|
||||
# $SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
# $SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
# { field => FID_PATRON_ID,
|
||||
# pat => qr/^$user_barcode$/,
|
||||
# required => 1, },
|
||||
# { field => FID_VALID_PATRON,
|
||||
# pat => qr/^Y$/,
|
||||
# required => 1, },
|
||||
# ];
|
||||
#
|
||||
#push @tests, $patron_disable_template, $test, $patron_enable_template;
|
||||
#
|
||||
SIPtest::run_sip_tests(@tests);
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,100 @@
|
|||
#!/usr/bin/perl
|
||||
# patron_status: test Patron Status Response
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Clone qw(clone);
|
||||
|
||||
use Sip::Constants qw(:all);
|
||||
|
||||
use SIPtest qw($datepat $textpat);
|
||||
|
||||
my $patron_status_test_template = {
|
||||
id => 'Patron Status: valid patron, no patron password',
|
||||
msg => '2300120060101 084237AOUWOLS|AAdjfiander|ACterminal password|',
|
||||
pat => qr/^24 [ Y]{13}001$datepat/,
|
||||
fields => [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^djfiander$/,
|
||||
required => 1, },
|
||||
{ field => FID_PERSONAL_NAME,
|
||||
pat => qr/^David J\. Fiander$/,
|
||||
required => 1, },
|
||||
{ field => FID_VALID_PATRON,
|
||||
pat => qr/^Y$/,
|
||||
# Not required by the spec, but by the test
|
||||
required => 1, },
|
||||
$SIPtest::field_specs{(FID_CURRENCY)},
|
||||
{ field => FID_FEE_AMT,
|
||||
pat => $textpat,
|
||||
required => 0, },
|
||||
], };
|
||||
|
||||
my @tests = (
|
||||
$SIPtest::login_test,
|
||||
$SIPtest::sc_status_test,
|
||||
clone($patron_status_test_template),
|
||||
);
|
||||
|
||||
# Invalid patron
|
||||
my $test = clone($patron_status_test_template);
|
||||
|
||||
$test->{id} = 'Patron Status invalid id';
|
||||
$test->{msg} =~ s/AAdjfiander\|/AAberick|/;
|
||||
|
||||
# The test assumes that the language sent by the terminal is
|
||||
# just echoed back for invalid patrons.
|
||||
$test->{pat} = qr/^24Y[ Y]{13}001$datepat/;
|
||||
|
||||
delete $test->{fields};
|
||||
$test->{fields} = [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^berick$/,
|
||||
required => 1, },
|
||||
{ field => FID_PERSONAL_NAME,
|
||||
pat => qr/^$/,
|
||||
required => 1, },
|
||||
{ field => FID_VALID_PATRON,
|
||||
pat => qr/^N$/,
|
||||
required => 1, },
|
||||
];
|
||||
|
||||
push @tests, $test;
|
||||
|
||||
# Valid patron, invalid patron password
|
||||
$test = clone($patron_status_test_template);
|
||||
$test->{id} = 'Patron Status: Valid patron, invalid patron password';
|
||||
$test->{msg} .= (FID_PATRON_PWD) . 'badpwd|';
|
||||
$test->{pat} = qr/^24[ Y]{14}001$datepat/;
|
||||
delete $test->{fields};
|
||||
$test->{fields} = [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^djfiander$/,
|
||||
required => 1, },
|
||||
{ field => FID_PERSONAL_NAME,
|
||||
pat => qr/^David J\. Fiander$/,
|
||||
required => 1, },
|
||||
{ field => FID_VALID_PATRON,
|
||||
pat => qr/^Y$/,
|
||||
required => 1, },
|
||||
{ field => FID_VALID_PATRON_PWD,
|
||||
pat => qr/^N$/,
|
||||
required => 1, },
|
||||
];
|
||||
push @tests, $test;
|
||||
|
||||
# TODO: Need multiple patrons to test each individual
|
||||
# status field
|
||||
|
||||
SIPtest::run_sip_tests(@tests);
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,45 @@
|
|||
#!/usr/bin/perl
|
||||
# block_patron: test Block Patron Response
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Clone qw(clone);
|
||||
|
||||
use Sip::Constants qw(:all);
|
||||
|
||||
use SIPtest qw($datepat $textpat $instid $user_barcode $user_fullname);
|
||||
|
||||
my $block_patron_test_template = {
|
||||
id => 'Block Patron: valid patron, card not retained',
|
||||
msg => "01N20060102 084238AO$instid|ALHe's a jerk|AA$user_barcode|ACterminal password|",
|
||||
# response to block patron is a patron status message
|
||||
pat => qr/^24Y[ Y]{13}000$datepat/o,
|
||||
fields => [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^$user_barcode$/o,
|
||||
required => 1, },
|
||||
{ field => FID_PERSONAL_NAME,
|
||||
pat => qr/^$user_fullname$/o,
|
||||
required => 1, },
|
||||
{ field => FID_VALID_PATRON,
|
||||
pat => qr/^Y$/,
|
||||
# Not required by the spec, but by the test
|
||||
required => 1, },
|
||||
$SIPtest::field_specs{(FID_CURRENCY)},
|
||||
{ field => FID_FEE_AMT,
|
||||
pat => $textpat,
|
||||
required => 0, },
|
||||
], };
|
||||
|
||||
my @tests = (
|
||||
$SIPtest::login_test,
|
||||
$SIPtest::sc_status_test,
|
||||
clone($block_patron_test_template),
|
||||
);
|
||||
|
||||
SIPtest::run_sip_tests(@tests);
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,144 @@
|
|||
#!/usr/bin/perl
|
||||
# patron_enable: test Patron Enable Response
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Clone qw(clone);
|
||||
|
||||
use Sip::Constants qw(:all);
|
||||
|
||||
use SIPtest qw($datepat $textpat);
|
||||
|
||||
my $patron_enable_test_template = {
|
||||
id => 'Patron Enable: valid patron',
|
||||
msg => "2520060102 084238AOUWOLS|AAdjfiander|",
|
||||
pat => qr/^26 {4}[ Y]{10}000$datepat/,
|
||||
fields => [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^djfiander$/,
|
||||
required => 1, },
|
||||
{ field => FID_PERSONAL_NAME,
|
||||
pat => qr/^David J\. Fiander$/,
|
||||
required => 1, },
|
||||
{ field => FID_VALID_PATRON,
|
||||
pat => qr/^Y$/,
|
||||
# Not required by the spec, but by the test
|
||||
required => 1, },
|
||||
], };
|
||||
|
||||
# We need to disable the valid patron before we can
|
||||
# ensure that he was properly enabled.
|
||||
my $patron_disable_test_template = {
|
||||
id => 'Patron Enable: block patron (prep to test enabling)',
|
||||
msg => "01N20060102 084238AOUWOLS|ALHe's a jerk|AAdjfiander|",
|
||||
# response to block patron is a patron status message
|
||||
pat => qr/^24Y{4}[ Y]{10}000$datepat/,
|
||||
fields => [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^djfiander$/,
|
||||
required => 1, },
|
||||
{ field => FID_PERSONAL_NAME,
|
||||
pat => qr/^David J\. Fiander$/,
|
||||
required => 1, },
|
||||
{ field => FID_VALID_PATRON,
|
||||
pat => qr/^Y$/,
|
||||
# Not required by the spec, but by the test
|
||||
required => 1, },
|
||||
], };
|
||||
|
||||
my @tests = (
|
||||
$SIPtest::login_test,
|
||||
$SIPtest::sc_status_test,
|
||||
$patron_disable_test_template,
|
||||
clone($patron_enable_test_template),
|
||||
);
|
||||
|
||||
my $test;
|
||||
|
||||
# Valid patron, valid password
|
||||
$test = clone($patron_enable_test_template);
|
||||
$test->{id} = "Patron Enable: valid patron, valid password";
|
||||
$test->{msg} .= FID_PATRON_PWD . '6789|';
|
||||
$test->{pat} = qr/^26 {4}[ Y]{10}000$datepat/;
|
||||
delete $test->{fields};
|
||||
$test->{fields} = [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^djfiander$/,
|
||||
required => 1, },
|
||||
{ field => FID_PERSONAL_NAME,
|
||||
pat => qr/^David J\. Fiander$/,
|
||||
required => 1, },
|
||||
{ field => FID_VALID_PATRON,
|
||||
pat => qr/^Y$/,
|
||||
# Not required by the spec, but by the test
|
||||
required => 1, },
|
||||
{ field => FID_VALID_PATRON_PWD,
|
||||
pat => qr/^Y$/,
|
||||
required => 1, },
|
||||
];
|
||||
|
||||
push @tests, $patron_disable_test_template, $test;
|
||||
|
||||
# Valid patron, invalid password
|
||||
$test = clone($patron_enable_test_template);
|
||||
$test->{id} = "Patron Enable: valid patron, invalid password";
|
||||
$test->{msg} .= FID_PATRON_PWD . 'bad password|';
|
||||
$test->{pat} = qr/^26[ Y]{14}000$datepat/;
|
||||
delete $test->{fields};
|
||||
$test->{fields} = [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^djfiander$/,
|
||||
required => 1, },
|
||||
{ field => FID_PERSONAL_NAME,
|
||||
pat => qr/^David J\. Fiander$/,
|
||||
required => 1, },
|
||||
{ field => FID_VALID_PATRON,
|
||||
pat => qr/^Y$/,
|
||||
# Not required by the spec, but by the test
|
||||
required => 1, },
|
||||
{ field => FID_VALID_PATRON_PWD,
|
||||
pat => qr/^N$/,
|
||||
required => 1, },
|
||||
];
|
||||
|
||||
push @tests, $patron_disable_test_template, $test;
|
||||
# After this test, the patron is left disabled, so re-enable
|
||||
push @tests, $patron_enable_test_template;
|
||||
|
||||
# Invalid patron
|
||||
$test = clone($patron_enable_test_template);
|
||||
$test->{id} =~ s/valid/invalid/;
|
||||
$test->{msg} =~ s/AAdjfiander\|/AAberick|/;
|
||||
$test->{pat} = qr/^26Y{4}[ Y]{10}000$datepat/;
|
||||
delete $test->{fields};
|
||||
$test->{fields} = [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^berick$/,
|
||||
required => 1, },
|
||||
{ field => FID_PERSONAL_NAME,
|
||||
pat => qr/^$/,
|
||||
required => 1, },
|
||||
{ field => FID_VALID_PATRON,
|
||||
pat => qr/^N$/,
|
||||
# Not required by the spec, but by the test
|
||||
required => 1, },
|
||||
];
|
||||
|
||||
push @tests, $test;
|
||||
|
||||
SIPtest::run_sip_tests(@tests);
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,187 @@
|
|||
#!/usr/bin/perl
|
||||
# patron_enable: test Patron Enable Response
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Clone qw(clone);
|
||||
|
||||
use Sip::Constants qw(:all);
|
||||
|
||||
use SIPtest qw($datepat $textpat);
|
||||
|
||||
my $hold_test_template = {
|
||||
id => 'Place Hold: valid item, valid patron',
|
||||
msg => '15+20060415 110158BW20060815 110158|BSTaylor|BY2|AOUWOLS|AAdjfiander|AB1565921879|',
|
||||
pat => qr/^161N$datepat/,
|
||||
fields => [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^djfiander$/,
|
||||
required => 1, },
|
||||
{ field => FID_EXPIRATION,
|
||||
pat => $datepat,
|
||||
required => 0, },
|
||||
{ field => FID_QUEUE_POS,
|
||||
pat => qr/^1$/,
|
||||
required => 1, },
|
||||
{ field => FID_PICKUP_LOCN,
|
||||
pat => qr/^Taylor$/,
|
||||
required => 1, },
|
||||
{ field => FID_TITLE_ID,
|
||||
pat => qr/^Perl 5 desktop reference$/,
|
||||
required => 1, },
|
||||
{ field => FID_ITEM_ID,
|
||||
pat => qr/^1565921879$/,
|
||||
required => 1, },
|
||||
],};
|
||||
|
||||
my $hold_count_test_template0 = {
|
||||
id => 'Confirm patron has 0 holds',
|
||||
msg => '6300020060329 201700 AOUWOLS|AAdjfiander|',
|
||||
pat => qr/^64 [ Y]{13}\d{3}${datepat}0000(\d{4}){5}/,
|
||||
fields => [],
|
||||
};
|
||||
|
||||
my $hold_count_test_template1 = {
|
||||
id => 'Confirm patron has 1 hold',
|
||||
msg => '6300020060329 201700 AOUWOLS|AAdjfiander|',
|
||||
pat => qr/^64 [ Y]{13}\d{3}${datepat}0001(\d{4}){5}/,
|
||||
fields => [],
|
||||
};
|
||||
|
||||
|
||||
my @tests = (
|
||||
$SIPtest::login_test,
|
||||
$SIPtest::sc_status_test,
|
||||
$hold_test_template, $hold_count_test_template1,
|
||||
);
|
||||
|
||||
my $test;
|
||||
|
||||
# Hold Queue: second hold placed on item
|
||||
$test = clone($hold_test_template);
|
||||
$test->{id} = 'Place hold: second hold on item';
|
||||
$test->{msg} =~ s/djfiander/miker/;
|
||||
$test->{pat} = qr/^161N$datepat/;
|
||||
foreach my $i (0 .. (scalar @{$test->{fields}})-1) {
|
||||
my $field = $test->{fields}[$i];
|
||||
|
||||
if ($field->{field} eq FID_PATRON_ID) {
|
||||
$field->{pat} = qr/^miker$/;
|
||||
} elsif ($field->{field} eq FID_QUEUE_POS) {
|
||||
$field->{pat} = qr/^2$/;
|
||||
}
|
||||
}
|
||||
|
||||
push @tests, $test;
|
||||
|
||||
# Cancel hold: valid hold
|
||||
$test = clone($hold_test_template);
|
||||
$test->{id} = 'Cancel hold: valid hold';
|
||||
$test->{msg} =~ s/\+/-/;
|
||||
$test->{pat} = qr/^161[NY]$datepat/;
|
||||
delete $test->{fields};
|
||||
$test->{fields} = [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^djfiander$/,
|
||||
required => 1, },
|
||||
];
|
||||
|
||||
push @tests, $test, $hold_count_test_template0;
|
||||
|
||||
# Cancel Hold: no hold on item
|
||||
# $test is already set up to cancel a hold, just change
|
||||
# the field tests
|
||||
$test = clone($test);
|
||||
$test->{id} = 'Cancel Hold: no hold on specified item';
|
||||
$test->{pat} = qr/^160N$datepat/;
|
||||
|
||||
push @tests, $test, $hold_count_test_template0;
|
||||
|
||||
# Cleanup: cancel miker's hold too.
|
||||
$test = clone($hold_test_template);
|
||||
$test->{id} = "Cancel hold: cleanup second patron's hold";
|
||||
$test->{msg} =~ s/\+/-/;
|
||||
$test->{msg} =~ s/djfiander/miker/;
|
||||
$test->{pat} = qr/^161[NY]$datepat/;
|
||||
delete $test->{fields};
|
||||
$test->{fields} = [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^miker$/,
|
||||
required => 1, },
|
||||
];
|
||||
|
||||
push @tests, $test;
|
||||
|
||||
# Place hold: valid patron, item, invalid patron pwd
|
||||
$test = clone($hold_test_template);
|
||||
$test->{id} = 'Place hold: invalid patron password';
|
||||
$test->{msg} .= FID_PATRON_PWD . 'bad password|';
|
||||
$test->{pat} = qr/^160N$datepat/;
|
||||
delete $test->{fields};
|
||||
$test->{fields} = [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^djfiander$/,
|
||||
required => 1, },
|
||||
];
|
||||
|
||||
push @tests, $test, $hold_count_test_template0;
|
||||
|
||||
# Place hold: invalid patron
|
||||
$test = clone($hold_test_template);
|
||||
$test->{id} = 'Place hold: invalid patron';
|
||||
$test->{msg} =~ s/AAdjfiander\|/AAberick|/;
|
||||
$test->{pat} = qr/^160N$datepat/;
|
||||
delete $test->{fields};
|
||||
$test->{fields} = [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^berick$/,
|
||||
required => 1, },
|
||||
];
|
||||
|
||||
# There's no patron to check the number of holds against
|
||||
push @tests, $test;
|
||||
|
||||
# Place hold: invalid item
|
||||
$test = clone($hold_test_template);
|
||||
$test->{id} = 'Place hold: invalid item';
|
||||
$test->{msg} =~ s/AB1565921879\|/ABnosuchitem|/;
|
||||
$test->{pat} = qr/^160N$datepat/;
|
||||
delete $test->{fields};
|
||||
$test->{fields} = [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^djfiander$/,
|
||||
required => 1, },
|
||||
{ field => FID_ITEM_ID,
|
||||
pat => qr/^nosuchitem$/,
|
||||
required => 0, },
|
||||
];
|
||||
|
||||
push @tests, $test, $hold_count_test_template0;
|
||||
|
||||
# Still need tests for:
|
||||
# - valid patron not permitted to place holds
|
||||
# - valid item, not allowed to hold item
|
||||
# - multiple holds on item: correct queue position management
|
||||
# - setting and verifying hold expiry dates (requires ILS support)
|
||||
|
||||
SIPtest::run_sip_tests(@tests);
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,67 @@
|
|||
#!/usr/bin/perl
|
||||
# checkin: test Checkin Response
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Clone qw(clone);
|
||||
|
||||
use Sip::Constants qw(:all);
|
||||
|
||||
use SIPtest qw($datepat $textpat $instid $user_barcode
|
||||
$item_barcode $item_title);
|
||||
|
||||
my $checkin_test_template = {
|
||||
id => 'Checkin: Item is checked out',
|
||||
msg => "09N20060102 08423620060113 084235APUnder the bed|AO$instid|AB$item_barcode|ACterminal password|",
|
||||
pat => qr/^101YNN$datepat/o,
|
||||
fields => [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^$user_barcode$/o,
|
||||
required => 1, },
|
||||
{ field => FID_ITEM_ID,
|
||||
pat => qr/^$item_barcode$/o,
|
||||
required => 1, },
|
||||
{ field => FID_PERM_LOCN,
|
||||
pat => $textpat,
|
||||
required => 1, },
|
||||
{ field => FID_TITLE_ID,
|
||||
pat => qr/^$item_title\s*$/o,
|
||||
required => 1, }, # not required by the spec.
|
||||
],};
|
||||
|
||||
my $checkout_template = {
|
||||
id => 'Checkin: prep: check out item',
|
||||
msg => "11YN20060329 203000 AO$instid|AA$user_barcode|AB$item_barcode|AC|",
|
||||
pat => qr/^121NNY$datepat/o,
|
||||
fields => [],
|
||||
};
|
||||
|
||||
my @tests = (
|
||||
$SIPtest::login_test,
|
||||
$SIPtest::sc_status_test,
|
||||
$checkout_template,
|
||||
$checkin_test_template,
|
||||
);
|
||||
|
||||
my $test;
|
||||
|
||||
# Checkin item that's not checked out. Basically, this
|
||||
# is identical to the first case, except the header says that
|
||||
# the ILS didn't check the item in, and there's no patron id.
|
||||
$test = clone($checkin_test_template);
|
||||
$test->{id} = 'Checkin: Item not checked out';
|
||||
$test->{pat} = qr/^100YNN$datepat/o;
|
||||
$test->{fields} = [grep $_->{field} ne FID_PATRON_ID, @{$test->{fields}}];
|
||||
|
||||
push @tests, $test;
|
||||
|
||||
#
|
||||
# Still need tests for magnetic media
|
||||
#
|
||||
|
||||
SIPtest::run_sip_tests(@tests);
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,147 @@
|
|||
#!/usr/bin/perl
|
||||
# renew: test Renew Response
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Clone qw(clone);
|
||||
|
||||
use Sip::Constants qw(:all);
|
||||
|
||||
use SIPtest qw($datepat $textpat $instid $currency $user_barcode
|
||||
$item_barcode $item_title);
|
||||
|
||||
my $checkout_template = {
|
||||
id => 'Renew: prep: check out item',
|
||||
msg => "11YN20060329 203000 AO$instid|AA$user_barcode|AB$item_barcode|AC|",
|
||||
pat => qr/^121NNY$datepat/,
|
||||
fields => [],
|
||||
};
|
||||
|
||||
my $checkin_template = {
|
||||
id => 'Renew: prep: check in item',
|
||||
msg => "09N20060102 08423620060113 084235APUnder the bed|AO$instid|AB$item_barcode|ACterminal password|",
|
||||
pat => qr/^101YNN$datepat/,
|
||||
fields => [],
|
||||
};
|
||||
|
||||
#my $hold_template = {
|
||||
# id => 'Renew: prep: place hold on item',
|
||||
# msg =>"15+20060415 110158BW20060815 110158|BSTaylor|BY2|AO$instid|AAmiker|AB$item_barcode|",
|
||||
# pat => qr/^161N$datepat/,
|
||||
# fields => [],
|
||||
# };
|
||||
#
|
||||
#my $cancel_hold_template = {
|
||||
# id => 'Renew: cleanup: cancel hold on item',
|
||||
# msg =>"15-20060415 110158BW20060815 110158|BSTaylor|BY2|AO$instid|AAmiker|AB$item_barcode|",
|
||||
# pat => qr/^161[NY]$datepat/,
|
||||
# fields => [],
|
||||
# };
|
||||
#
|
||||
|
||||
my $renew_test_template = {
|
||||
id => 'Renew: item id checked out to patron, renewal permitted, no 3rd party, no fees',
|
||||
msg => "29NN20060102 084236 AO$instid|AA$user_barcode|AB$item_barcode|",
|
||||
pat => qr/^301YNN$datepat/,
|
||||
fields => [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_PATRON_ID,
|
||||
pat => qr/^$user_barcode$/,
|
||||
required => 1, },
|
||||
{ field => FID_ITEM_ID,
|
||||
pat => qr/^$item_barcode$/,
|
||||
required => 1, },
|
||||
{ field => FID_TITLE_ID,
|
||||
pat => qr/^$item_title\s*$/,
|
||||
required => 1, },
|
||||
{ field => FID_DUE_DATE,
|
||||
pat => qr/^$datepat$/,
|
||||
required => 1, },
|
||||
{ field => FID_SECURITY_INHIBIT,
|
||||
pat => qr/^[YN]$/,
|
||||
required => 0, },
|
||||
],};
|
||||
|
||||
my @tests = (
|
||||
$SIPtest::login_test,
|
||||
$SIPtest::sc_status_test,
|
||||
$checkout_template,
|
||||
$renew_test_template,
|
||||
);
|
||||
|
||||
my $test;
|
||||
|
||||
# Renew: item checked out, identify by title
|
||||
#$test = clone($renew_test_template);
|
||||
#$test->{id} = 'Renew: identify item by title';
|
||||
#$test->{msg} =~ s/AB$item_barcode\|/AJ$item_title|/;
|
||||
## Everything else should be the same
|
||||
#push @tests, $test;
|
||||
#
|
||||
## Renew: Item checked out, but another patron has placed a hold
|
||||
#$test = clone($renew_test_template);
|
||||
#$test->{id} = 'Renew: Item has outstanding hold';
|
||||
#$test->{pat} = qr/^300NUN$datepat/;
|
||||
#foreach my $field (@{$test->{fields}}) {
|
||||
# if ($field->{field} eq FID_DUE_DATE || $field->{field} eq FID_TITLE_ID) {
|
||||
# $field->{pat} = qr/^$/;
|
||||
# }
|
||||
#}
|
||||
#
|
||||
#push @tests, $hold_template, $test, $cancel_hold_template;
|
||||
#
|
||||
# Renew: item not checked out. Basically the same, except
|
||||
# for the leader test.
|
||||
$test = clone($renew_test_template);
|
||||
$test->{id} = 'Renew: item not checked out at all';
|
||||
$test->{pat} = qr/^300NUN$datepat/;
|
||||
foreach my $field (@{$test->{fields}}) {
|
||||
if ($field->{field} eq FID_DUE_DATE) {
|
||||
$field->{pat} = qr/^$/;
|
||||
} elsif ($field->{field} eq FID_TITLE_ID) {
|
||||
$field->{pat} = qr/^($item_title\s*|)$/;
|
||||
}
|
||||
}
|
||||
|
||||
push @tests, $checkin_template, $test;
|
||||
|
||||
$test = clone($renew_test_template);
|
||||
$test->{id} = 'Renew: Invalid item';
|
||||
$test->{msg} =~ s/AB[^|]+/ABbad-item/;
|
||||
$test->{pat} = qr/^300NUN$datepat/;
|
||||
foreach my $field (@{$test->{fields}}) {
|
||||
if ($field->{field} eq FID_TITLE_ID || $field->{field} eq FID_DUE_DATE) {
|
||||
$field->{pat} = qr/^$/;
|
||||
} elsif ($field->{field} eq FID_ITEM_ID) {
|
||||
$field->{pat} = qr/^bad-item$/;
|
||||
}
|
||||
}
|
||||
|
||||
push @tests, $test;
|
||||
|
||||
$test = clone($renew_test_template);
|
||||
$test->{id} = 'Renew: Invalid user';
|
||||
$test->{msg} =~ s/AA$user_barcode/AAberick/;
|
||||
$test->{pat} = qr/^300NUN$datepat/;
|
||||
foreach my $field (@{$test->{fields}}) {
|
||||
if ($field->{field} eq FID_DUE_DATE) {
|
||||
$field->{pat} = qr/^$/;
|
||||
} elsif ($field->{field} eq FID_PATRON_ID) {
|
||||
$field->{pat} = qr/^berick$/;
|
||||
} elsif ($field->{field} eq FID_TITLE_ID) {
|
||||
$field->{pat} = qr/^($item_title\s*|)$/;
|
||||
}
|
||||
}
|
||||
|
||||
push @tests, $test;
|
||||
|
||||
# Still need tests for
|
||||
# - renewing a for-fee item
|
||||
# - patrons that are not permitted to renew
|
||||
# - renewing item that has reached limit on number of renewals
|
||||
|
||||
SIPtest::run_sip_tests(@tests);
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,107 @@
|
|||
#!/usr/bin/perl
|
||||
# renew_all: test Renew All Response
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Clone qw(clone);
|
||||
|
||||
use Sip::Constants qw(:all);
|
||||
|
||||
use SIPtest qw($datepat $textpat $user_barcode $item_barcode $item_owner
|
||||
$item2_barcode $item2_owner $instid);
|
||||
|
||||
my $enable_template = {
|
||||
id => 'Renew All: prep: enable patron permissions',
|
||||
msg => "2520060102 084238AO$instid|AA$user_barcode|",
|
||||
pat => qr/^26 {4}[ Y]{10}000$datepat/,
|
||||
fields => [],
|
||||
};
|
||||
|
||||
my @checkout_templates = (
|
||||
{ id => "Renew All: prep: check out $item_barcode",
|
||||
msg => "11YN20060329 203000 AO$instid|AA$user_barcode|AB$item_barcode|AC|",
|
||||
pat => qr/^121NNY$datepat/,
|
||||
fields => [],},
|
||||
{ id => "Renew All: prep: check out $item2_barcode",
|
||||
msg => "11YN20060329 203000 AO$instid|AA$user_barcode|AB$item2_barcode|AC|",
|
||||
pat => qr/^121NNY$datepat/,
|
||||
fields => [],}
|
||||
);
|
||||
|
||||
my @checkin_templates = (
|
||||
{ id => "Renew All: prep: check in $item_barcode",
|
||||
msg => "09N20060102 08423620060113 084235APUnder the bed|AO$instid|AB$item_barcode|ACterminal password|",
|
||||
pat => qr/^101YNN$datepat/,
|
||||
fields => [],},
|
||||
{ id => "Renew All: prep: check in $item2_barcode",
|
||||
msg => "09N20060102 08423620060113 084235APUnder the bed|AO$instid|AB$item2_barcode|ACterminal password|",
|
||||
pat => qr/^101YNN$datepat/,
|
||||
fields => [],}
|
||||
);
|
||||
|
||||
my $renew_all_test_template = {
|
||||
id => 'Renew All: valid patron with one item checked out, no patron password',
|
||||
msg => "6520060102 084236AO$instid|AA$user_barcode|",
|
||||
pat => qr/^66100010000$datepat/,
|
||||
fields => [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_RENEWED_ITEMS,
|
||||
pat => qr/^$item_barcode$/,
|
||||
required => 1, },
|
||||
],};
|
||||
|
||||
my @tests = (
|
||||
$SIPtest::login_test,
|
||||
$SIPtest::sc_status_test,
|
||||
# $enable_template,
|
||||
$checkout_templates[0],
|
||||
$renew_all_test_template,
|
||||
$checkin_templates[0], # check the book in, when done testing
|
||||
);
|
||||
|
||||
my $test;
|
||||
|
||||
#$test = clone($renew_all_test_template);
|
||||
#$test->{id} = 'Renew All: Valid patron, two items checked out';
|
||||
#$test->{pat} = qr/^66100020000$datepat/;
|
||||
#foreach my $i (0 .. (scalar @{$test->{fields}})-1) {
|
||||
# my $field = $test->{fields}[$i];
|
||||
#
|
||||
# if ($field->{field} eq FID_RENEWED_ITEMS) {
|
||||
# $field->{pat} = qr/^$item_barcode\|$item2_barcode$/;
|
||||
# }
|
||||
#}
|
||||
#
|
||||
#push @tests, $checkout_templates[0], $checkout_templates[1],
|
||||
# $renew_all_test_template, $checkin_templates[0], $checkin_templates[1];
|
||||
|
||||
$test = clone($renew_all_test_template);
|
||||
$test->{id} = 'Renew All: valid patron, invalid patron password';
|
||||
$test->{msg} .= (FID_PATRON_PWD) . 'badpwd|';
|
||||
$test->{pat} = qr/^66000000000$datepat/;
|
||||
delete $test->{fields};
|
||||
$test->{fields} = [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
];
|
||||
|
||||
push @tests, $checkout_templates[0], $test, $checkin_templates[0];
|
||||
|
||||
$test = clone($renew_all_test_template);
|
||||
$test->{id} = 'Renew All: invalid patron';
|
||||
$test->{msg} =~ s/AA$user_barcode/AAberick/;
|
||||
$test->{pat} = qr/^66000000000$datepat/;
|
||||
delete $test->{fields};
|
||||
$test->{fields} = [
|
||||
$SIPtest::field_specs{(FID_INST_ID)},
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
];
|
||||
push @tests, $test;
|
||||
|
||||
SIPtest::run_sip_tests(@tests);
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
#!/usr/bin/perl
|
||||
# renew_all: test Renew All Response
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Clone qw(clone);
|
||||
|
||||
use Sip::Constants qw(:all);
|
||||
|
||||
use SIPtest qw($datepat $textpat $instid $currency $user_barcode
|
||||
$item_barcode $item_title $item_owner);
|
||||
|
||||
my $item_info_test_template = {
|
||||
id => 'Item Information: check information for available item',
|
||||
msg => "1720060110 215612AO$instid|AB$item_barcode|",
|
||||
pat => qr/^180[13]0201$datepat/, # status of 'other' or 'available'
|
||||
fields => [
|
||||
$SIPtest::field_specs{(FID_SCREEN_MSG)},
|
||||
$SIPtest::field_specs{(FID_PRINT_LINE)},
|
||||
{ field => FID_ITEM_ID,
|
||||
pat => qr/^$item_barcode$/,
|
||||
required => 1, },
|
||||
{ field => FID_TITLE_ID,
|
||||
pat => qr/^$item_title\s*$/,
|
||||
required => 1, },
|
||||
{ field => FID_MEDIA_TYPE,
|
||||
pat => qr/^\d{3}$/,
|
||||
required => 0, },
|
||||
{ field => FID_OWNER,
|
||||
pat => qr/^$item_owner$/,
|
||||
required => 0, },
|
||||
], };
|
||||
|
||||
my @tests = (
|
||||
$SIPtest::login_test,
|
||||
$SIPtest::sc_status_test,
|
||||
clone($item_info_test_template),
|
||||
);
|
||||
|
||||
SIPtest::run_sip_tests(@tests);
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
#
|
||||
#
|
||||
#
|
||||
|
||||
TESTS = 00sc_status.t 01patron_status.t 02patron_info.t 03checkout.t \
|
||||
04patron_status.t 05block_patron.t 06patron_enable.t 07hold.t \
|
||||
08checkin.t 09renew.t 10renew_all.t 11item_info.t
|
||||
|
||||
OILS_TESTS = 00sc_status.t 01patron_status.t 02patron_info.t 03checkout.t \
|
||||
08checkin.t 09renew.t 11item_info.t 05block_patron.t
|
||||
|
||||
test-openils:
|
||||
prove -I.. $(OILS_TESTS)
|
||||
|
||||
test:
|
||||
prove -I.. $(TESTS)
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
CONFIGURING THE TEST SUITE
|
||||
|
||||
Before you can run the test suite, you need to configure certain
|
||||
information about the SIP server and the ILS data in the file
|
||||
SIPtest.pm.
|
||||
|
||||
RUNNING THE TESTS
|
||||
|
||||
Every file tests a different protocol transaction.
|
||||
Unfortunately, a lot of test cases are missing, but the basics
|
||||
are tested, as are most of the simple error conditions (invalid
|
||||
users, unknown items, checking in item that's not checked out).
|
||||
|
||||
To run a single test, just run
|
||||
|
||||
perl -I.. <file>
|
||||
|
||||
If the test fails, the output should be pretty clear about what
|
||||
went wrong (assuming you can read raw SIP packets).
|
||||
|
||||
To run all the tests, just type
|
||||
|
||||
make test
|
||||
|
||||
Right now, that will run tests for functionality that isn't
|
||||
supported in the Evergreen environment (the two main cases are
|
||||
enable patron and hold management). To run just the Evergreen tests, use
|
||||
|
||||
make test-openils
|
||||
|
||||
which will run just the tests
|
||||
|
||||
00sc_status.t
|
||||
01patron_status.t
|
||||
02patron_info.t
|
||||
03checkout.t
|
||||
06patron_enable.t
|
||||
08checkin.t
|
||||
09renew.t
|
||||
11item_info.t
|
||||
05block_patron.t
|
||||
|
||||
NOTE: the Block Patron tests are run last because "Patron Enable"
|
||||
isn't supported. Thus, after running the "Block Patron" test,
|
||||
manual intervention is required to unblock the test patron.
|
||||
|
||||
The Renew All tests will fail when running the stub "ILS"
|
||||
implementation unless there's only one ILS server running. This
|
||||
won't be a problem for any real backend implementation that
|
||||
properly manages the database of users and items.
|
||||
|
|
@ -0,0 +1,225 @@
|
|||
package SIPtest;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Exporter;
|
||||
|
||||
our @ISA = qw(Exporter);
|
||||
|
||||
our @EXPORT_OK = qw(run_sip_tests no_tagged_fields
|
||||
$datepat $textpat
|
||||
$login_test $sc_status_test
|
||||
%field_specs
|
||||
|
||||
$instid $currency $server $username $password
|
||||
$user_barcode $user_pin $user_fullname $user_homeaddr
|
||||
$user_email $user_phone $user_birthday $user_ptype
|
||||
$user_inet
|
||||
$item_barcode $item_title $item_owner
|
||||
$item2_barcode $item2_title $item2_owner
|
||||
$item_diacritic_barcode $item_diacritic_title
|
||||
$item_diacritic_owner);
|
||||
#use Data::Dumper;
|
||||
|
||||
# The number of tests is set in run_sip_tests() below, based
|
||||
# on the size of the array of tests.
|
||||
use Test::More;
|
||||
|
||||
use IO::Socket::INET;
|
||||
use Sip qw(:all);
|
||||
use Sip::Checksum qw(verify_cksum);
|
||||
use Sip::Constants qw(:all);
|
||||
|
||||
#
|
||||
# Configuration parameters to run the test suite
|
||||
#
|
||||
our $instid = 'UWOLS';
|
||||
our $currency = 'CAD';
|
||||
our $server = 'localhost:6001'; # Address of the SIP server
|
||||
|
||||
# SIP username and password to connect to the server. See the
|
||||
# SIP config.xml for the correct values.
|
||||
our $username = 'scclient';
|
||||
our $password = 'clientpwd';
|
||||
|
||||
# ILS Information
|
||||
|
||||
# Valid user barcode and corresponding user password/pin and full name
|
||||
our $user_barcode = 'djfiander';
|
||||
our $user_pin = '6789';
|
||||
our $user_fullname= 'David J\. Fiander';
|
||||
our $user_homeaddr= '2 Meadowvale Dr\. St Thomas, ON';
|
||||
our $user_email = 'djfiander\@hotmail\.com';
|
||||
our $user_phone = '\(519\) 555 1234';
|
||||
our $user_birthday= '19640925';
|
||||
our $user_ptype = 'A';
|
||||
our $user_inet = 'Y';
|
||||
|
||||
# Valid item barcode and corresponding title
|
||||
our $item_barcode = '1565921879';
|
||||
our $item_title = 'Perl 5 desktop reference';
|
||||
our $item_owner = 'UWOLS';
|
||||
|
||||
# Another valid item
|
||||
our $item2_barcode = '0440242746';
|
||||
our $item2_title = 'The deep blue alibi';
|
||||
our $item2_owner = 'UWOLS';
|
||||
|
||||
# An item with a diacritical in the title
|
||||
our $item_diacritic_barcode = '660';
|
||||
our $item_diacritic_title = 'Harry Potter y el cáliz de fuego';
|
||||
our $item_diacritic_owner = 'UWOLS';
|
||||
|
||||
# End configuration
|
||||
|
||||
# Pattern for a SIP datestamp, to be used by individual tests to
|
||||
# match timestamp fields (duh).
|
||||
our $datepat = '\d{8} {4}\d{6}';
|
||||
|
||||
# Pattern for a random text field (may be empty)
|
||||
our $textpat = qr/^[^|]*$/;
|
||||
|
||||
our %field_specs = (
|
||||
(FID_SCREEN_MSG) => { field => FID_SCREEN_MSG,
|
||||
pat => $textpat,
|
||||
required => 0, },
|
||||
(FID_PRINT_LINE) => { field => FID_PRINT_LINE,
|
||||
pat => $textpat,
|
||||
required => 0, },
|
||||
(FID_INST_ID) => { field => FID_INST_ID,
|
||||
pat => qr/^$instid$/o,
|
||||
required => 1, },
|
||||
(FID_HOLD_ITEMS_LMT)=> { field => FID_HOLD_ITEMS_LMT,
|
||||
pat => qr/^\d{4}$/,
|
||||
required => 0, },
|
||||
(FID_OVERDUE_ITEMS_LMT)=> { field => FID_OVERDUE_ITEMS_LMT,
|
||||
pat => qr/^\d{4}$/,
|
||||
required => 0, },
|
||||
(FID_CHARGED_ITEMS_LMT)=> { field => FID_CHARGED_ITEMS_LMT,
|
||||
pat => qr/^\d{4}$/,
|
||||
required => 0, },
|
||||
(FID_VALID_PATRON) => { field => FID_VALID_PATRON,
|
||||
pat => qr/^[NY]$/,
|
||||
required => 0, },
|
||||
(FID_VALID_PATRON_PWD)=> { field => FID_VALID_PATRON_PWD,
|
||||
pat => qr/^[NY]$/,
|
||||
required => 0, },
|
||||
(FID_CURRENCY) => { field => FID_CURRENCY,
|
||||
pat => qr/^$currency$/io,
|
||||
required => 0, },
|
||||
);
|
||||
|
||||
# Login and SC Status are always the first two messages that
|
||||
# the terminal sends to the server, so just create the test
|
||||
# cases here and reference them in the individual test files.
|
||||
|
||||
our $login_test = { id => 'login',
|
||||
msg => "9300CN$username|CO$password|CPThe floor|",
|
||||
pat => qr/^941/,
|
||||
fields => [], };
|
||||
|
||||
our $sc_status_test = { id => 'SC status',
|
||||
msg => '9910302.00',
|
||||
pat => qr/^98[YN]{6}\d{3}\d{3}$datepat(2\.00|1\.00)/,
|
||||
fields => [
|
||||
$field_specs{(FID_SCREEN_MSG)},
|
||||
$field_specs{(FID_PRINT_LINE)},
|
||||
$field_specs{(FID_INST_ID)},
|
||||
{ field => 'AM',
|
||||
pat => $textpat,
|
||||
required => 0, },
|
||||
{ field => 'BX',
|
||||
pat => qr/^[YN]{16}$/,
|
||||
required => 1, },
|
||||
{ field => 'AN',
|
||||
pat => $textpat,
|
||||
required => 0, },
|
||||
],
|
||||
};
|
||||
|
||||
sub one_msg {
|
||||
my ($sock, $test, $seqno) = @_;
|
||||
my $resp;
|
||||
my %fields;
|
||||
|
||||
# If reading or writing fails, then the server's dead,
|
||||
# so there's no point in continuing.
|
||||
if (!write_msg({seqno => $seqno}, $test->{msg}, $sock)) {
|
||||
BAIL_OUT("Write failure in $test->{id}");
|
||||
} elsif (!($resp = <$sock>)) {
|
||||
BAIL_OUT("Read failure in $test->{id}");
|
||||
}
|
||||
|
||||
chomp($resp);
|
||||
|
||||
if (!verify_cksum($resp)) {
|
||||
fail("checksum $test->{id}");
|
||||
return;
|
||||
}
|
||||
if ($resp !~ $test->{pat}) {
|
||||
fail("match leader $test->{id}");
|
||||
diag("Response '$resp' doesn't match pattern '$test->{pat}'");
|
||||
return;
|
||||
}
|
||||
|
||||
# Split the tagged fields of the response into (name, value)
|
||||
# pairs and stuff them into the hash.
|
||||
$resp =~ $test->{pat};
|
||||
%fields = substr($resp, $+[0]) =~ /(..)([^|]*)\|/go;
|
||||
|
||||
# print STDERR Dumper($test);
|
||||
# print STDERR Dumper(\%fields);
|
||||
if (!defined($test->{fields})) {
|
||||
diag("TODO: $test->{id} field tests not written yet");
|
||||
} else {
|
||||
# If there are no tagged fields, then 'fields' should be an
|
||||
# empty list which will automatically skip this loop
|
||||
foreach my $ftest (@{$test->{fields}}) {
|
||||
my $field = $ftest->{field};
|
||||
|
||||
if ($ftest->{required} && !exists($fields{$field})) {
|
||||
fail("$test->{id} required field '$field' exists in '$resp'");
|
||||
return;
|
||||
}
|
||||
|
||||
if (exists($fields{$field}) && ($fields{$field} !~ $ftest->{pat})) {
|
||||
|
||||
fail("$test->{id} field test $field");
|
||||
diag("Field pattern '$ftest->{pat}' for '$field' doesn't match in '$resp'");
|
||||
return;
|
||||
}
|
||||
}
|
||||
}
|
||||
pass("$test->{id}");
|
||||
return;
|
||||
}
|
||||
|
||||
#
|
||||
# _count_tests: Count the number of tests in a test array
|
||||
sub _count_tests {
|
||||
return scalar @_;
|
||||
}
|
||||
|
||||
sub run_sip_tests {
|
||||
my ($sock, $seqno);
|
||||
|
||||
$Sip::error_detection = 1;
|
||||
$/ = "\r";
|
||||
|
||||
$sock = new IO::Socket::INET(PeerAddr => $server,
|
||||
Type => SOCK_STREAM);
|
||||
|
||||
BAIL_OUT('failed to create connection to server') unless $sock;
|
||||
|
||||
$seqno = 1;
|
||||
|
||||
plan tests => _count_tests(@_);
|
||||
|
||||
foreach my $test (@_) {
|
||||
one_msg($sock, $test, $seqno++);
|
||||
$seqno %= 10; # sequence number is one digit
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
97AZFEF5
|
||||
2300120060101 084235AOUWOLS|AAdjfiander|ACterminal password|ADuser password|
|
||||
2300120060101 084236AOUWOLS|AAmjandkilde|ACterminal password|ADuser password|
|
||||
2300120060101 084237AOUWOLS|AAdjfiander|ACterminal password|ADuser password|
|
||||
9300CNLoginUserID|COLoginPassword|CPLocationCode|
|
||||
11YN20060329 203000 AOUWOLS|AAdjfiander|AB1565921879|AC|
|
||||
09Y20060102 08423620060113 084235APUnder the bed|AOUWOLS|AB1565921879|ACterminal password|
|
||||
01N20060102 084238AOUWOLS|ALHe's a jerk|AAdjfiander|ACterminal password|
|
||||
2520060102 084238AOUWOLS|AAdjfiander|ACterminal password|AD6789|
|
||||
9910302.00
|
||||
3520060110 084237AOUWOLS|AAdjfiander|AD6789|
|
||||
1720060110 215612AOUWOLS|AB1565921879|
|
||||
6300020060329 201700Y AOUWOLS|AAdjfiander|
|
||||
15+20060415 110158BW20060815 110158|BSTaylor|BY2|AOUWOLS|AAdjfiander|AB1565921879|
|
||||
15-20060415 110158AOUWOLS|AAdjfiander|AB1565921879|
|
||||
29NN20060415 110158 AOUWOLS|AAdjfiander|AD6789|AB1565921879|
|
||||
6520060415 110158AOUWOLS|AAdjfiander|AD6789|
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
#
|
||||
# This file reads a SIPServer xml-format configuration file and dumps it
|
||||
# to stdout. Just to see what the structures look like.
|
||||
#
|
||||
# The 'new XML::Simple' option must agree exactly with the configuration
|
||||
# in Sip::Configuration.pm
|
||||
#
|
||||
use strict;
|
||||
use English;
|
||||
|
||||
use XML::Simple qw(:strict);
|
||||
use Data::Dumper;
|
||||
|
||||
my $parser = new XML::Simple( KeyAttr => { login => '+id',
|
||||
institution => '+id',
|
||||
service => '+port', },
|
||||
GroupTags => { listeners => 'service',
|
||||
accounts => 'login',
|
||||
institutions => 'institution', },
|
||||
ForceArray=> [ 'service',
|
||||
'login',
|
||||
'institution' ],
|
||||
ValueAttr => { 'error-detect' => 'enabled',
|
||||
'min_servers' => 'value',
|
||||
'max_servers' => 'value'} );
|
||||
|
||||
my $ref = $parser->XMLin($ARGV[0]);
|
||||
|
||||
print Dumper($ref);
|
||||
|
|
@ -0,0 +1,617 @@
|
|||
#
|
||||
# ILS.pm: Test ILS interface module
|
||||
#
|
||||
|
||||
package OpenILS::SIP;
|
||||
use warnings; use strict;
|
||||
|
||||
use Sys::Syslog qw(syslog);
|
||||
|
||||
use OpenILS::SIP::Item;
|
||||
use OpenILS::SIP::Patron;
|
||||
use OpenILS::SIP::Transaction;
|
||||
use OpenILS::SIP::Transaction::Checkout;
|
||||
use OpenILS::SIP::Transaction::Checkin;
|
||||
use OpenILS::SIP::Transaction::Renew;
|
||||
|
||||
use OpenSRF::System;
|
||||
use OpenILS::Utils::Fieldmapper;
|
||||
use OpenSRF::Utils::SettingsClient;
|
||||
use OpenILS::Application::AppUtils;
|
||||
use OpenSRF::Utils qw/:datetime/;
|
||||
use DateTime::Format::ISO8601;
|
||||
my $U = 'OpenILS::Application::AppUtils';
|
||||
|
||||
my $editor;
|
||||
my $config;
|
||||
|
||||
use Digest::MD5 qw(md5_hex);
|
||||
|
||||
sub new {
|
||||
my ($class, $institution, $login) = @_;
|
||||
my $type = ref($class) || $class;
|
||||
my $self = {};
|
||||
|
||||
$self->{login} = $login;
|
||||
|
||||
$config = $institution;
|
||||
syslog("LOG_DEBUG", "OILS: new ILS '%s'", $institution->{id});
|
||||
$self->{institution} = $institution;
|
||||
|
||||
my $bsconfig = $institution->{implementation_config}->{bootstrap};
|
||||
|
||||
syslog('LOG_DEBUG', "OILS: loading bootstrap config: $bsconfig");
|
||||
|
||||
local $/ = "\n";
|
||||
OpenSRF::System->bootstrap_client(config_file => $bsconfig);
|
||||
syslog('LOG_DEBUG', "OILS: bootstrap loaded..");
|
||||
|
||||
$self->{osrf_config} = OpenSRF::Utils::SettingsClient->new;
|
||||
|
||||
Fieldmapper->import($self->{osrf_config}->config_value('IDL'));
|
||||
|
||||
bless( $self, $type );
|
||||
|
||||
return undef unless
|
||||
$self->login( $login->{id}, $login->{password} );
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub verify_session {
|
||||
my $self = shift;
|
||||
my $ses = $U->simplereq(
|
||||
'open-ils.auth',
|
||||
'open-ils.auth.session.retrieve', $self->{authtoken} );
|
||||
return 1 unless $U->event_code($ses);
|
||||
syslog('LOG_INFO', "OILS: Logging back after session timeout as user ".$self->{login}->{id});
|
||||
return $self->login( $self->{login}->{id}, $self->{login}->{password} );
|
||||
}
|
||||
|
||||
sub to_bool {
|
||||
my $val = shift;
|
||||
return ($val and $val =~ /true/io);
|
||||
}
|
||||
|
||||
sub editor {
|
||||
return $editor
|
||||
if $editor and $editor->{session}
|
||||
and $editor->session->connected;
|
||||
return $editor = make_editor();
|
||||
}
|
||||
|
||||
sub reset_editor {
|
||||
$editor = undef;
|
||||
return editor();
|
||||
}
|
||||
|
||||
sub config {
|
||||
return $config;
|
||||
}
|
||||
|
||||
|
||||
# Creates the global editor object
|
||||
sub make_editor {
|
||||
require OpenILS::Utils::CStoreEditor;
|
||||
my $e = OpenILS::Utils::CStoreEditor->new(xact => 1);
|
||||
# gnarly cstore hack to re-gen autogen methods after IDL is loaded
|
||||
if(!UNIVERSAL::can($e, 'search_actor_card')) {
|
||||
syslog("LOG_WARNING", "OILS: Reloading CStoreEditor...");
|
||||
delete $INC{'OpenILS/Utils/CStoreEditor.pm'};
|
||||
require OpenILS::Utils::CStoreEditor;
|
||||
$e = OpenILS::Utils::CStoreEditor->new(xact =>1);
|
||||
}
|
||||
return $e;
|
||||
}
|
||||
|
||||
sub format_date {
|
||||
my $class = shift;
|
||||
my $date = shift;
|
||||
my $type = shift || 'dob';
|
||||
|
||||
return "" unless $date;
|
||||
|
||||
$date = DateTime::Format::ISO8601->new->
|
||||
parse_datetime(OpenSRF::Utils::clense_ISO8601($date));
|
||||
my @time = localtime($date->epoch);
|
||||
|
||||
my $year = $time[5]+1900;
|
||||
my $mon = $time[4]+1;
|
||||
my $day = $time[3];
|
||||
|
||||
$mon =~ s/^(\d)$/0$1/;
|
||||
$day =~ s/^(\d)$/0$1/;
|
||||
$date = "$year$mon$day";
|
||||
|
||||
$date = $year.'-'.$mon.'-'.$day .' 00:00:00' if $type eq 'due';
|
||||
#$date = $year.'-'.$mon.'-'.$day if $type eq 'due';
|
||||
|
||||
syslog('LOG_DEBUG', "OILS: formatted date [type=$type]: $date");
|
||||
return $date;
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub login {
|
||||
my( $self, $username, $password ) = @_;
|
||||
syslog('LOG_DEBUG', "OILS: Logging in with username $username");
|
||||
|
||||
my $seed = $U->simplereq(
|
||||
'open-ils.auth',
|
||||
'open-ils.auth.authenticate.init', $username );
|
||||
|
||||
my $response = $U->simplereq(
|
||||
'open-ils.auth',
|
||||
'open-ils.auth.authenticate.complete',
|
||||
{
|
||||
username => $username,
|
||||
password => md5_hex($seed . md5_hex($password)),
|
||||
type => 'opac',
|
||||
}
|
||||
);
|
||||
|
||||
if( my $code = $U->event_code($response) ) {
|
||||
my $txt = $response->{textcode};
|
||||
syslog('LOG_WARNING', "OILS: Login failed for $username. $txt:$code");
|
||||
return undef;
|
||||
}
|
||||
|
||||
my $key = $response->{payload}->{authtoken};
|
||||
syslog('LOG_INFO', "OILS: Login succeeded for $username : authkey = $key");
|
||||
return $self->{authtoken} = $key;
|
||||
}
|
||||
|
||||
|
||||
sub find_patron {
|
||||
my $self = shift;
|
||||
return OpenILS::SIP::Patron->new(@_);
|
||||
}
|
||||
|
||||
|
||||
sub find_item {
|
||||
my $self = shift;
|
||||
return OpenILS::SIP::Item->new(@_);
|
||||
}
|
||||
|
||||
|
||||
sub institution {
|
||||
my $self = shift;
|
||||
return $self->{institution}->{id};
|
||||
}
|
||||
|
||||
sub supports {
|
||||
my ($self, $op) = @_;
|
||||
my ($i) = grep { $_->{name} eq $op }
|
||||
@{$config->{implementation_config}->{supports}->{item}};
|
||||
return to_bool($i->{value});
|
||||
}
|
||||
|
||||
sub check_inst_id {
|
||||
my ($self, $id, $whence) = @_;
|
||||
if ($id ne $self->{institution}->{id}) {
|
||||
syslog("LOG_WARNING",
|
||||
"OILS: %s: received institution '%s', expected '%s'",
|
||||
$whence, $id, $self->{institution}->{id});
|
||||
}
|
||||
}
|
||||
|
||||
sub checkout_ok {
|
||||
return to_bool($config->{policy}->{checkout});
|
||||
}
|
||||
|
||||
sub checkin_ok {
|
||||
return to_bool($config->{policy}->{checkin});
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub renew_ok {
|
||||
return to_bool($config->{policy}->{renew});
|
||||
}
|
||||
|
||||
sub status_update_ok {
|
||||
return to_bool($config->{policy}->{status_update});
|
||||
}
|
||||
|
||||
sub offline_ok {
|
||||
return to_bool($config->{policy}->{offline});
|
||||
}
|
||||
|
||||
|
||||
|
||||
##
|
||||
## Checkout(patron_id, item_id, sc_renew):
|
||||
## patron_id & item_id are the identifiers send by the terminal
|
||||
## sc_renew is the renewal policy configured on the terminal
|
||||
## returns a status opject that can be queried for the various bits
|
||||
## of information that the protocol (SIP or NCIP) needs to generate
|
||||
## the response.
|
||||
##
|
||||
|
||||
sub checkout {
|
||||
my ($self, $patron_id, $item_id, $sc_renew) = @_;
|
||||
|
||||
$self->verify_session;
|
||||
|
||||
syslog('LOG_DEBUG', "OILS: OpenILS::Checkout attempt: patron=$patron_id, item=$item_id");
|
||||
|
||||
my $xact = OpenILS::SIP::Transaction::Checkout->new( authtoken => $self->{authtoken} );
|
||||
my $patron = $self->find_patron($patron_id);
|
||||
my $item = $self->find_item($item_id);
|
||||
|
||||
$xact->patron($patron);
|
||||
$xact->item($item);
|
||||
|
||||
if (!$patron) {
|
||||
$xact->screen_msg("Invalid Patron");
|
||||
return $xact;
|
||||
}
|
||||
|
||||
if (!$patron->charge_ok) {
|
||||
$xact->screen_msg("Patron Blocked");
|
||||
return $xact;
|
||||
}
|
||||
|
||||
if( !$item ) {
|
||||
$xact->screen_msg("Invalid Item");
|
||||
return $xact;
|
||||
}
|
||||
|
||||
syslog('LOG_DEBUG', "OILS: OpenILS::Checkout data loaded OK, checking out...");
|
||||
$xact->do_checkout();
|
||||
|
||||
if ($item->{patron} && ($item->{patron} ne $patron_id)) {
|
||||
# I can't deal with this right now
|
||||
# XXX check in then check out?
|
||||
$xact->screen_msg("Item checked out to another patron");
|
||||
$xact->ok(0);
|
||||
}
|
||||
|
||||
$xact->desensitize(!$item->magnetic);
|
||||
|
||||
if( $xact->ok ) {
|
||||
|
||||
#editor()->commit;
|
||||
syslog("LOG_DEBUG", "OILS: OpenILS::Checkout: " .
|
||||
"patron %s checkout %s succeeded", $patron_id, $item_id);
|
||||
|
||||
} else {
|
||||
|
||||
#editor()->xact_rollback;
|
||||
syslog("LOG_DEBUG", "OILS: OpenILS::Checkout: " .
|
||||
"patron %s checkout %s FAILED, rolling back xact...", $patron_id, $item_id);
|
||||
}
|
||||
|
||||
return $xact;
|
||||
}
|
||||
|
||||
|
||||
sub checkin {
|
||||
my ($self, $item_id, $trans_date, $return_date,
|
||||
$current_loc, $item_props, $cancel) = @_;
|
||||
|
||||
$self->verify_session;
|
||||
|
||||
syslog('LOG_DEBUG', "OILS: OpenILS::Checkin on item=$item_id");
|
||||
|
||||
my $patron;
|
||||
my $xact = OpenILS::SIP::Transaction::Checkin->new(authtoken => $self->{authtoken});
|
||||
my $item = $self->find_item($item_id);
|
||||
|
||||
$xact->item($item);
|
||||
|
||||
if(!$xact->item) {
|
||||
$xact->screen_msg("Invalid item barcode: $item_id");
|
||||
$xact->ok(0);
|
||||
return $xact;
|
||||
}
|
||||
|
||||
$xact->do_checkin( $trans_date, $return_date, $current_loc, $item_props );
|
||||
|
||||
if ($xact->ok) {
|
||||
|
||||
$xact->patron($patron = $self->find_patron($item->{patron}));
|
||||
delete $item->{patron};
|
||||
delete $item->{due_date};
|
||||
syslog('LOG_INFO', "OILS: Checkin succeeded");
|
||||
#editor()->commit;
|
||||
|
||||
} else {
|
||||
|
||||
#editor()->xact_rollback;
|
||||
syslog('LOG_WARNING', "OILS: Checkin failed");
|
||||
}
|
||||
# END TRANSACTION
|
||||
|
||||
return $xact;
|
||||
}
|
||||
|
||||
## If the ILS caches patron information, this lets it free it up
|
||||
sub end_patron_session {
|
||||
my ($self, $patron_id) = @_;
|
||||
return (1, 'Thank you for using OpenILS!', '');
|
||||
}
|
||||
|
||||
|
||||
#sub pay_fee {
|
||||
# my ($self, $patron_id, $patron_pwd, $fee_amt, $fee_type,
|
||||
# $pay_type, $fee_id, $trans_id, $currency) = @_;
|
||||
# my $trans;
|
||||
# my $patron;
|
||||
#
|
||||
# $trans = new ILS::Transaction::FeePayment;
|
||||
#
|
||||
# $patron = new ILS::Patron $patron_id;
|
||||
#
|
||||
# $trans->transaction_id($trans_id);
|
||||
# $trans->patron($patron);
|
||||
# $trans->ok(1);
|
||||
#
|
||||
# return $trans;
|
||||
#}
|
||||
#
|
||||
#sub add_hold {
|
||||
# my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
|
||||
# $expiry_date, $pickup_location, $hold_type, $fee_ack) = @_;
|
||||
# my ($patron, $item);
|
||||
# my $hold;
|
||||
# my $trans;
|
||||
#
|
||||
#
|
||||
# $trans = new ILS::Transaction::Hold;
|
||||
#
|
||||
# # BEGIN TRANSACTION
|
||||
# $patron = new ILS::Patron $patron_id;
|
||||
# if (!$patron
|
||||
# || (defined($patron_pwd) && !$patron->check_password($patron_pwd))) {
|
||||
# $trans->screen_msg("Invalid Patron.");
|
||||
#
|
||||
# return $trans;
|
||||
# }
|
||||
#
|
||||
# $item = new ILS::Item ($item_id || $title_id);
|
||||
# if (!$item) {
|
||||
# $trans->screen_msg("No such item.");
|
||||
#
|
||||
# # END TRANSACTION (conditionally)
|
||||
# return $trans;
|
||||
# } elsif ($item->fee && ($fee_ack ne 'Y')) {
|
||||
# $trans->screen_msg = "Fee required to place hold.";
|
||||
#
|
||||
# # END TRANSACTION (conditionally)
|
||||
# return $trans;
|
||||
# }
|
||||
#
|
||||
# $hold = {
|
||||
# item_id => $item->id,
|
||||
# patron_id => $patron->id,
|
||||
# expiration_date => $expiry_date,
|
||||
# pickup_location => $pickup_location,
|
||||
# hold_type => $hold_type,
|
||||
# };
|
||||
#
|
||||
# $trans->ok(1);
|
||||
# $trans->patron($patron);
|
||||
# $trans->item($item);
|
||||
# $trans->pickup_location($pickup_location);
|
||||
#
|
||||
# push(@{$item->hold_queue}, $hold);
|
||||
# push(@{$patron->{hold_items}}, $hold);
|
||||
#
|
||||
#
|
||||
# # END TRANSACTION
|
||||
# return $trans;
|
||||
#}
|
||||
#
|
||||
#sub cancel_hold {
|
||||
# my ($self, $patron_id, $patron_pwd, $item_id, $title_id) = @_;
|
||||
# my ($patron, $item, $hold);
|
||||
# my $trans;
|
||||
#
|
||||
# $trans = new ILS::Transaction::Hold;
|
||||
#
|
||||
# # BEGIN TRANSACTION
|
||||
# $patron = new ILS::Patron $patron_id;
|
||||
# if (!$patron) {
|
||||
# $trans->screen_msg("Invalid patron barcode.");
|
||||
#
|
||||
# return $trans;
|
||||
# } elsif (defined($patron_pwd) && !$patron->check_password($patron_pwd)) {
|
||||
# $trans->screen_msg('Invalid patron password.');
|
||||
#
|
||||
# return $trans;
|
||||
# }
|
||||
#
|
||||
# $item = new ILS::Item ($item_id || $title_id);
|
||||
# if (!$item) {
|
||||
# $trans->screen_msg("No such item.");
|
||||
#
|
||||
# # END TRANSACTION (conditionally)
|
||||
# return $trans;
|
||||
# }
|
||||
#
|
||||
# # Remove the hold from the patron's record first
|
||||
# $trans->ok($patron->drop_hold($item_id));
|
||||
#
|
||||
# if (!$trans->ok) {
|
||||
# # We didn't find it on the patron record
|
||||
# $trans->screen_msg("No such hold on patron record.");
|
||||
#
|
||||
# # END TRANSACTION (conditionally)
|
||||
# return $trans;
|
||||
# }
|
||||
#
|
||||
# # Now, remove it from the item record. If it was on the patron
|
||||
# # record but not on the item record, we'll treat that as success.
|
||||
# foreach my $i (0 .. scalar @{$item->hold_queue}) {
|
||||
# $hold = $item->hold_queue->[$i];
|
||||
#
|
||||
# if ($hold->{patron_id} eq $patron->id) {
|
||||
# # found it: delete it.
|
||||
# splice @{$item->hold_queue}, $i, 1;
|
||||
# last;
|
||||
# }
|
||||
# }
|
||||
#
|
||||
# $trans->screen_msg("Hold Cancelled.");
|
||||
# $trans->patron($patron);
|
||||
# $trans->item($item);
|
||||
#
|
||||
# return $trans;
|
||||
#}
|
||||
#
|
||||
#
|
||||
## The patron and item id's can't be altered, but the
|
||||
## date, location, and type can.
|
||||
#sub alter_hold {
|
||||
# my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
|
||||
# $expiry_date, $pickup_location, $hold_type, $fee_ack) = @_;
|
||||
# my ($patron, $item);
|
||||
# my $hold;
|
||||
# my $trans;
|
||||
#
|
||||
# $trans = new ILS::Transaction::Hold;
|
||||
#
|
||||
# # BEGIN TRANSACTION
|
||||
# $patron = new ILS::Patron $patron_id;
|
||||
# if (!$patron) {
|
||||
# $trans->screen_msg("Invalid patron barcode.");
|
||||
#
|
||||
# return $trans;
|
||||
# }
|
||||
#
|
||||
# foreach my $i (0 .. scalar @{$patron->{hold_items}}) {
|
||||
# $hold = $patron->{hold_items}[$i];
|
||||
#
|
||||
# if ($hold->{item_id} eq $item_id) {
|
||||
# # Found it. So fix it.
|
||||
# $hold->{expiration_date} = $expiry_date if $expiry_date;
|
||||
# $hold->{pickup_location} = $pickup_location if $pickup_location;
|
||||
# $hold->{hold_type} = $hold_type if $hold_type;
|
||||
#
|
||||
# $trans->ok(1);
|
||||
# $trans->screen_msg("Hold updated.");
|
||||
# $trans->patron($patron);
|
||||
# $trans->item(new ILS::Item $hold->{item_id});
|
||||
# last;
|
||||
# }
|
||||
# }
|
||||
#
|
||||
# # The same hold structure is linked into both the patron's
|
||||
# # list of hold items and into the queue of outstanding holds
|
||||
# # for the item, so we don't need to search the hold queue for
|
||||
# # the item, since it's already been updated by the patron code.
|
||||
#
|
||||
# if (!$trans->ok) {
|
||||
# $trans->screen_msg("No such outstanding hold.");
|
||||
# }
|
||||
#
|
||||
# return $trans;
|
||||
#}
|
||||
|
||||
|
||||
sub renew {
|
||||
my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
|
||||
$no_block, $nb_due_date, $third_party, $item_props, $fee_ack) = @_;
|
||||
|
||||
$self->verify_session;
|
||||
|
||||
my $trans = OpenILS::SIP::Transaction::Renew->new( authtoken => $self->{authtoken} );
|
||||
$trans->patron($self->find_patron($patron_id));
|
||||
$trans->item($self->find_item($item_id));
|
||||
|
||||
if(!$trans->patron) {
|
||||
$trans->screen_msg("Invalid patron barcode.");
|
||||
$trans->ok(0);
|
||||
return $trans;
|
||||
}
|
||||
|
||||
if(!$trans->patron->renew_ok) {
|
||||
$trans->screen_msg("Renewals not allowed.");
|
||||
$trans->ok(0);
|
||||
return $trans;
|
||||
}
|
||||
|
||||
if(!$trans->item) {
|
||||
if( $title_id ) {
|
||||
$trans->screen_msg("Item Id renewal not supported.");
|
||||
} else {
|
||||
$trans->screen_msg("Invalid item barcode.");
|
||||
}
|
||||
$trans->ok(0);
|
||||
return $trans;
|
||||
}
|
||||
|
||||
if(!$trans->item->{patron} or
|
||||
$trans->item->{patron} ne $patron_id) {
|
||||
$trans->screen_msg("Item not checked out to " . $trans->patron->name);
|
||||
$trans->ok(0);
|
||||
return $trans;
|
||||
}
|
||||
|
||||
# Perform the renewal
|
||||
$trans->do_renew();
|
||||
|
||||
$trans->desensitize(0); # It's already checked out
|
||||
$trans->item->{due_date} = $nb_due_date if $no_block eq 'Y';
|
||||
$trans->item->{sip_item_properties} = $item_props if $item_props;
|
||||
|
||||
return $trans;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#
|
||||
#sub renew_all {
|
||||
# my ($self, $patron_id, $patron_pwd, $fee_ack) = @_;
|
||||
# my ($patron, $item_id);
|
||||
# my $trans;
|
||||
#
|
||||
# $trans = new ILS::Transaction::RenewAll;
|
||||
#
|
||||
# $trans->patron($patron = new ILS::Patron $patron_id);
|
||||
# if (defined $patron) {
|
||||
# syslog("LOG_DEBUG", "ILS::renew_all: patron '%s': renew_ok: %s",
|
||||
# $patron->name, $patron->renew_ok);
|
||||
# } else {
|
||||
# syslog("LOG_DEBUG", "ILS::renew_all: Invalid patron id: '%s'",
|
||||
# $patron_id);
|
||||
# }
|
||||
#
|
||||
# if (!defined($patron)) {
|
||||
# $trans->screen_msg("Invalid patron barcode.");
|
||||
# return $trans;
|
||||
# } elsif (!$patron->renew_ok) {
|
||||
# $trans->screen_msg("Renewals not allowed.");
|
||||
# return $trans;
|
||||
# } elsif (defined($patron_pwd) && !$patron->check_password($patron_pwd)) {
|
||||
# $trans->screen_msg("Invalid patron password.");
|
||||
# return $trans;
|
||||
# }
|
||||
#
|
||||
# foreach $item_id (@{$patron->{items}}) {
|
||||
# my $item = new ILS::Item $item_id;
|
||||
#
|
||||
# if (!defined($item)) {
|
||||
# syslog("LOG_WARNING",
|
||||
# "renew_all: Invalid item id associated with patron '%s'",
|
||||
# $patron->id);
|
||||
# next;
|
||||
# }
|
||||
#
|
||||
# if (@{$item->hold_queue}) {
|
||||
# # Can't renew if there are outstanding holds
|
||||
# push @{$trans->unrenewed}, $item_id;
|
||||
# } else {
|
||||
# $item->{due_date} = time + (14*24*60*60); # two weeks hence
|
||||
# push @{$trans->renewed}, $item_id;
|
||||
# }
|
||||
# }
|
||||
#
|
||||
# $trans->ok(1);
|
||||
#
|
||||
# return $trans;
|
||||
#}
|
||||
|
||||
1;
|
||||
Loading…
Reference in New Issue