--- /dev/null
+#
+# 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;
--- /dev/null
+=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
--- /dev/null
+#
+# 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;
--- /dev/null
+=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
--- /dev/null
+#
+# 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;
--- /dev/null
+=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.
--- /dev/null
+#
+# 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;
--- /dev/null
+#
+# 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;
--- /dev/null
+#
+# 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;
--- /dev/null
+package ILS::Transaction::FeePaid;
+
+use Exporter;
+use warnings;
+use strict;
+
+use ILS;
+use ILS::Transaction;
+
+our @ISA = qw(Exporter ILS::Transaction);
+
+1;
--- /dev/null
+#
+# 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;
--- /dev/null
+#
+# 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;
--- /dev/null
+#
+# 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;
--- /dev/null
+#
+# 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
--- /dev/null
+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.
--- /dev/null
+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 = '';
+ }
+}
--- /dev/null
+<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>
--- /dev/null
+#
+# 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;
--- /dev/null
+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;
--- /dev/null
+#
+# 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;
--- /dev/null
+#
+#
+#
+#
+
+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;
--- /dev/null
+#
+#
+#
+#
+
+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;
--- /dev/null
+#
+#
+#
+#
+
+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;
--- /dev/null
+#
+# 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",
+};
--- /dev/null
+#
+# Sip::MsgType.pm
+#
+# A Class for handing SIP messages
+#
+
+package Sip::MsgType;
+
+use strict;
+use warnings;
+use Exporter;
+use Sys::Syslog qw(syslog);
+use UNIVERSAL qw(can);
+
+use Sip qw(:all);
+use Sip::Constants qw(:all);
+use Sip::Checksum qw(verify_cksum);
+
+use Data::Dumper;
+
+our (@ISA, @EXPORT_OK);
+
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(handle);
+
+# Predeclare handler subroutines
+use subs qw(handle_patron_status handle_checkout handle_checkin
+ handle_block_patron handle_sc_status handle_request_acs_resend
+ handle_login handle_patron_info handle_end_patron_session
+ handle_fee_paid handle_item_information handle_item_status_update
+ handle_patron_enable handle_hold handle_renew handle_renew_all);
+
+#
+# For the most part, Version 2.00 of the protocol just adds new
+# variable fields, but sometimes it changes the fixed header.
+#
+# In general, if there's no '2.00' protocol entry for a handler, that's
+# because 2.00 didn't extend the 1.00 version of the protocol. This will
+# be handled by the module initialization code following the declaration,
+# which goes through the handlers table and creates a '2.00' entry that
+# points to the same place as the '1.00' entry. If there's a 2.00 entry
+# but no 1.00 entry, then that means that it's a completely new service
+# in 2.00, so 1.00 shouldn't recognize it.
+
+my %handlers = (
+ (PATRON_STATUS_REQ) => {
+ name => "Patron Status Request",
+ handler => \&handle_patron_status,
+ protocol => {
+ 1 => {
+ template => "A3A18",
+ template_len => 21,
+ fields => [(FID_INST_ID), (FID_PATRON_ID),
+ (FID_TERMINAL_PWD), (FID_PATRON_PWD)],
+ }
+ }
+ },
+ (CHECKOUT) => {
+ name => "Checkout",
+ handler => \&handle_checkout,
+ protocol => {
+ 1 => {
+ template => "CCA18A18",
+ template_len => 38,
+ fields => [(FID_INST_ID), (FID_PATRON_ID),
+ (FID_ITEM_ID), (FID_TERMINAL_PWD)],
+ },
+ 2 => {
+ template => "CCA18A18",
+ template_len => 38,
+ fields => [(FID_INST_ID), (FID_PATRON_ID),
+ (FID_ITEM_ID), (FID_TERMINAL_PWD),
+ (FID_ITEM_PROPS), (FID_PATRON_PWD),
+ (FID_FEE_ACK), (FID_CANCEL)],
+ },
+ }
+ },
+ (CHECKIN) => {
+ name => "Checkin",
+ handler => \&handle_checkin,
+ protocol => {
+ 1 => {
+ template => "CA18A18",
+ template_len => 37,
+ fields => [(FID_CURRENT_LOCN), (FID_INST_ID),
+ (FID_ITEM_ID), (FID_TERMINAL_PWD)],
+ },
+ 2 => {
+ template => "CA18A18",
+ template_len => 37,
+ fields => [(FID_CURRENT_LOCN), (FID_INST_ID),
+ (FID_ITEM_ID), (FID_TERMINAL_PWD),
+ (FID_ITEM_PROPS), (FID_CANCEL)],
+ }
+ }
+ },
+ (BLOCK_PATRON) => {
+ name => "Block Patron",
+ handler => \&handle_block_patron,
+ protocol => {
+ 1 => {
+ template => "CA18",
+ template_len => 19,
+ fields => [(FID_INST_ID), (FID_BLOCKED_CARD_MSG),
+ (FID_PATRON_ID), (FID_TERMINAL_PWD)],
+ },
+ }
+ },
+ (SC_STATUS) => {
+ name => "SC Status",
+ handler => \&handle_sc_status,
+ protocol => {
+ 1 => {
+ template =>"CA3A4",
+ template_len => 8,
+ fields => [],
+ }
+ }
+ },
+ (REQUEST_ACS_RESEND) => {
+ name => "Request ACS Resend",
+ handler => \&handle_request_acs_resend,
+ protocol => {
+ 1 => {
+ template => "",
+ template_len => 0,
+ fields => [],
+ }
+ }
+ },
+ (LOGIN) => {
+ name => "Login",
+ handler => \&handle_login,
+ protocol => {
+ 2 => {
+ template => "A1A1",
+ template_len => 2,
+ fields => [(FID_LOGIN_UID), (FID_LOGIN_PWD),
+ (FID_LOCATION_CODE)],
+ }
+ }
+ },
+ (PATRON_INFO) => {
+ name => "Patron Info",
+ handler => \&handle_patron_info,
+ protocol => {
+ 2 => {
+ template => "A3A18A10",
+ template_len => 31,
+ fields => [(FID_INST_ID), (FID_PATRON_ID),
+ (FID_TERMINAL_PWD), (FID_PATRON_PWD),
+ (FID_START_ITEM), (FID_END_ITEM)],
+ }
+ }
+ },
+ (END_PATRON_SESSION) => {
+ name => "End Patron Session",
+ handler => \&handle_end_patron_session,
+ protocol => {
+ 2 => {
+ template => "A18",
+ template_len => 18,
+ fields => [(FID_INST_ID), (FID_PATRON_ID),
+ (FID_TERMINAL_PWD), (FID_PATRON_PWD)],
+ }
+ }
+ },
+ (FEE_PAID) => {
+ name => "Fee Paid",
+ handler => \&handle_fee_paid,
+ protocol => {
+ 2 => {
+ template => "A18A2A3",
+ template_len => 0,
+ fields => [(FID_FEE_AMT), (FID_INST_ID),
+ (FID_PATRON_ID), (FID_TERMINAL_PWD),
+ (FID_PATRON_PWD), (FID_FEE_ID),
+ (FID_TRANSACTION_ID)],
+ }
+ }
+ },
+ (ITEM_INFORMATION) => {
+ name => "Item Information",
+ handler => \&handle_item_information,
+ protocol => {
+ 2 => {
+ template => "A18",
+ template_len => 18,
+ fields => [(FID_INST_ID), (FID_ITEM_ID),
+ (FID_TERMINAL_PWD)],
+ }
+ }
+ },
+ (ITEM_STATUS_UPDATE) => {
+ name => "Item Status Update",
+ handler => \&handle_item_status_update,
+ protocol => {
+ 2 => {
+ template => "A18",
+ template_len => 18,
+ fields => [(FID_INST_ID), (FID_PATRON_ID),
+ (FID_ITEM_ID), (FID_TERMINAL_PWD),
+ (FID_ITEM_PROPS)],
+ }
+ }
+ },
+ (PATRON_ENABLE) => {
+ name => "Patron Enable",
+ handler => \&handle_patron_enable,
+ protocol => {
+ 2 => {
+ template => "A18",
+ template_len => 18,
+ fields => [(FID_INST_ID), (FID_PATRON_ID),
+ (FID_TERMINAL_PWD), (FID_PATRON_PWD)],
+ }
+ }
+ },
+ (HOLD) => {
+ name => "Hold",
+ handler => \&handle_hold,
+ protocol => {
+ 2 => {
+ template => "AA18",
+ template_len => 19,
+ fields => [(FID_EXPIRATION), (FID_PICKUP_LOCN),
+ (FID_HOLD_TYPE), (FID_INST_ID),
+ (FID_PATRON_ID), (FID_PATRON_PWD),
+ (FID_ITEM_ID), (FID_TITLE_ID),
+ (FID_TERMINAL_PWD), (FID_FEE_ACK)],
+ }
+ }
+ },
+ (RENEW) => {
+ name => "Renew",
+ handler => \&handle_renew,
+ protocol => {
+ 2 => {
+ template => "CCA18A18",
+ template_len => 38,
+ fields => [(FID_INST_ID), (FID_PATRON_ID),
+ (FID_PATRON_PWD), (FID_ITEM_ID),
+ (FID_TITLE_ID), (FID_TERMINAL_PWD),
+ (FID_ITEM_PROPS), (FID_FEE_ACK)],
+ }
+ }
+ },
+ (RENEW_ALL) => {
+ name => "Renew All",
+ handler => \&handle_renew_all,
+ protocol => {
+ 2 => {
+ template => "A18",
+ template_len => 18,
+ fields => [(FID_INST_ID), (FID_PATRON_ID),
+ (FID_PATRON_PWD), (FID_TERMINAL_PWD),
+ (FID_FEE_ACK)],
+ }
+ }
+ }
+ );
+
+#
+# Now, initialize some of the missing bits of %handlers
+#
+foreach my $i (keys(%handlers)) {
+ if (!exists($handlers{$i}->{protocol}->{2})) {
+
+ $handlers{$i}->{protocol}->{2} = $handlers{$i}->{protocol}->{1};
+ }
+}
+
+sub new {
+ my ($class, $msg, $seqno) = @_;
+ my $self = {};
+ my $msgtag = substr($msg, 0, 2);
+
+ syslog("LOG_DEBUG", "Sip::MsgType::new('%s', '%s', '%s'): msgtag '%s'",
+ $class, substr($msg, 0, 10), $msgtag, $seqno);
+ if ($msgtag eq LOGIN) {
+ # If the client is using the 2.00-style "Login" message
+ # to authenticate to the server, then we get the Login message
+ # _before_ the client has indicated that it supports 2.00, but
+ # it's using the 2.00 login process, so it must support 2.00,
+ # so we'll just do it.
+ $protocol_version = 2;
+ }
+ if (!exists($handlers{$msgtag})) {
+ syslog("LOG_WARNING",
+ "new Sip::MsgType: Skipping message of unknown type '%s' in '%s'",
+ $msgtag, $msg);
+ return(undef);
+ } elsif (!exists($handlers{$msgtag}->{protocol}->{$protocol_version})) {
+ syslog("LOG_WARNING", "new Sip::MsgType: Skipping message '%s' unsupported by protocol rev. '%d'",
+ $msgtag, $protocol_version);
+ return(undef);
+ }
+
+ bless $self, $class;
+
+ $self->{seqno} = $seqno;
+ $self->_initialize(substr($msg,2), $handlers{$msgtag});
+
+ return($self);
+}
+
+sub _initialize {
+ my ($self, $msg, $control_block) = @_;
+ my ($fs, $fn, $fe);
+ my $proto = $control_block->{protocol}->{$protocol_version};
+
+ $self->{name} = $control_block->{name};
+ $self->{handler} = $control_block->{handler};
+
+ $self->{fields} = {};
+ $self->{fixed_fields} = [];
+
+ syslog("LOG_DEBUG", "Sip::MsgType:_initialize('%s', '%s...')",
+ $self->{name}, substr($msg, 0, 20));
+
+ foreach my $field (@{$proto->{fields}}) {
+ $self->{fields}->{$field} = undef;
+ }
+
+ syslog("LOG_DEBUG",
+ "Sip::MsgType::_initialize('%s', '%s', '%s', '%s', ...",
+ $self->{name}, $msg, $proto->{template},
+ $proto->{template_len});
+
+ $self->{fixed_fields} = [ unpack($proto->{template}, $msg) ];
+
+ # Skip over the fixed fields and the split the rest of
+ # the message into fields based on the delimiter and parse them
+ foreach my $field (split(quotemeta($field_delimiter), substr($msg, $proto->{template_len}))) {
+ $fn = substr($field, 0, 2);
+
+ if (!exists($self->{fields}->{$fn})) {
+ syslog("LOG_WARNING",
+ "Unsupported field '%s' in %s message '%s'",
+ $fn, $self->{name}, $msg);
+ } elsif (defined($self->{fields}->{$fn})) {
+ syslog("LOG_WARNING",
+ "Duplicate field '%s' (previous value '%s') in %s message '%s'",
+ $fn, $self->{fields}->{$fn}, $self->{name}, $msg);
+ } else {
+ $self->{fields}->{$fn} = substr($field, 2);
+ }
+ }
+
+ return($self);
+}
+
+sub handle {
+ my ($msg, $server, $req) = @_;
+ my $config = $server->{config};
+ my $self;
+
+
+ #
+ # What's the field delimiter for variable length fields?
+ # This can't be based on the account, since we need to know
+ # the field delimiter to parse a SIP login message
+ #
+ if (defined($server->{config}->{delimiter})) {
+ $field_delimiter = $server->{config}->{delimiter};
+ }
+
+ # error detection is active if this is a REQUEST_ACS_RESEND
+ # message with a checksum, or if the message is long enough
+ # and the last nine characters begin with a sequence number
+ # field
+ if ($msg eq REQUEST_ACS_RESEND_CKSUM) {
+ # Special case
+
+ $error_detection = 1;
+ $self = new Sip::MsgType ((REQUEST_ACS_RESEND), 0);
+ } elsif((length($msg) > 11) && (substr($msg, -9, 2) eq "AY")) {
+ $error_detection = 1;
+
+ if (!verify_cksum($msg)) {
+ syslog("LOG_WARNING", "Checksum failed on message '%s'", $msg);
+ # REQUEST_SC_RESEND with error detection
+ $last_response = REQUEST_SC_RESEND_CKSUM;
+ print("$last_response\r");
+ return REQUEST_ACS_RESEND;
+ } else {
+ # Save the sequence number, then strip off the
+ # error detection data to process the message
+ $self = new Sip::MsgType (substr($msg, 0, -9), substr($msg, -7, 1));
+ }
+ } elsif ($error_detection) {
+ # We've receive a non-ED message when ED is supposed
+ # to be active. Warn about this problem, then process
+ # the message anyway.
+ syslog("LOG_WARNING",
+ "Received message without error detection: '%s'", $msg);
+ $error_detection = 0;
+ $self = new Sip::MsgType ($msg, 0);
+ } else {
+ $self = new Sip::MsgType ($msg, 0);
+ }
+
+ if ((substr($msg, 0, 2) ne REQUEST_ACS_RESEND) &&
+ $req && (substr($msg, 0, 2) ne $req)) {
+ return substr($msg, 0, 2);
+ }
+ return($self->{handler}->($self, $server));
+}
+
+##
+## Message Handlers
+##
+
+#
+# Patron status messages are produced in response to both
+# "Request Patron Status" and "Block Patron"
+#
+# Request Patron Status requires a patron password, but
+# Block Patron doesn't (since the patron may never have
+# provided one before attempting some illegal action).
+#
+# ASSUMPTION: If the patron password field is present in the
+# message, then it must match, otherwise incomplete patron status
+# information will be returned to the terminal.
+#
+sub build_patron_status {
+ my ($patron, $lang, $fields)= @_;
+ my $patron_pwd = $fields->{(FID_PATRON_PWD)};
+ my $resp = (PATRON_STATUS_RESP);
+
+ if ($patron) {
+ $resp .= patron_status_string($patron);
+ $resp .= $lang . Sip::timestamp();
+ $resp .= add_field(FID_PERSONAL_NAME, $patron->name);
+
+ # while the patron ID we got from the SC is valid, let's
+ # use the one returned from the ILS, just in case...
+ $resp .= add_field(FID_PATRON_ID, $patron->id);
+ if ($protocol_version >= 2) {
+ $resp .= add_field(FID_VALID_PATRON, 'Y');
+ # If the patron password field doesn't exist, then
+ # we can't report that the password was valid, now can
+ # we? But if it does exist, then we know it's valid.
+ if (defined($patron_pwd)) {
+ $resp .= add_field(FID_VALID_PATRON_PWD,
+ sipbool($patron->check_password($patron_pwd)));
+ }
+ $resp .= maybe_add(FID_CURRENCY, $patron->currency);
+ $resp .= maybe_add(FID_FEE_AMT, $patron->fee_amount);
+ }
+
+ $resp .= maybe_add(FID_SCREEN_MSG, $patron->screen_msg);
+ $resp .= maybe_add(FID_PRINT_LINE, $patron->print_line);
+ } else {
+ # Invalid patron id. Report that the user has no privs.,
+ # no personal name, and is invalid (if we're using 2.00)
+ $resp .= 'YYYY' . (' ' x 10) . $lang . Sip::timestamp();
+ $resp .= add_field(FID_PERSONAL_NAME, '');
+
+ # the patron ID is invalid, but it's a required field, so
+ # just echo it back
+ $resp .= add_field(FID_PATRON_ID, $fields->{(FID_PATRON_ID)});
+
+ if ($protocol_version >= 2) {
+ $resp .= add_field(FID_VALID_PATRON, 'N');
+ }
+ }
+
+ $resp .= add_field(FID_INST_ID, $fields->{(FID_INST_ID)});
+
+ return $resp;
+}
+
+sub handle_patron_status {
+ my ($self, $server) = @_;
+ my $ils = $server->{ils};
+ my ($lang, $date);
+ my $fields;
+ my $patron;
+ my $resp = (PATRON_STATUS_RESP);
+ my $account = $server->{account};
+
+ ($lang, $date) = @{$self->{fixed_fields}};
+ $fields = $self->{fields};
+
+ $ils->check_inst_id($fields->{(FID_INST_ID)}, "handle_patron_status");
+
+ $patron = $ils->find_patron($fields->{(FID_PATRON_ID)});
+
+ $resp = build_patron_status($patron, $lang, $fields);
+
+ $self->write_msg($resp);
+
+ return (PATRON_STATUS_REQ);
+}
+
+sub handle_checkout {
+ my ($self, $server) = @_;
+ my $account = $server->{account};
+ my $ils = $server->{ils};
+ my $inst = $ils->institution;
+ my ($sc_renewal_policy, $no_block, $trans_date, $nb_due_date);
+ my $fields;
+ my ($patron_id, $item_id, $status);
+ my ($item, $patron);
+ my $resp;
+
+ ($sc_renewal_policy, $no_block, $trans_date, $nb_due_date) =
+ @{$self->{fixed_fields}};
+ $fields = $self->{fields};
+
+ $patron_id = $fields->{(FID_PATRON_ID)};
+ $item_id = $fields->{(FID_ITEM_ID)};
+
+
+ if ($no_block eq 'Y') {
+ # Off-line transactions need to be recorded, but there's
+ # not a lot we can do about it
+ syslog("LOG_WARN", "received no-block checkout from terminal '%s'",
+ $account->{id});
+
+ $status = $ils->checkout_no_block($patron_id, $item_id,
+ $sc_renewal_policy,
+ $trans_date, $nb_due_date);
+ } else {
+ # Does the transaction date really matter for items that are
+ # checkout out while the terminal is online? I'm guessing 'no'
+ $status = $ils->checkout($patron_id, $item_id, $sc_renewal_policy);
+ }
+
+
+ $item = $status->item;
+ $patron = $status->patron;
+
+ if ($status->ok) {
+ # Item successfully checked out
+ # Fixed fields
+ $resp = CHECKOUT_RESP . '1';
+ $resp .= sipbool($status->renew_ok);
+ if ($ils->supports('magnetic media')) {
+ $resp .= sipbool($item->magnetic);
+ } else {
+ $resp .= 'U';
+ }
+ # We never return the obsolete 'U' value for 'desensitize'
+ $resp .= sipbool($status->desensitize);
+ $resp .= Sip::timestamp;
+
+ # Now for the variable fields
+ $resp .= add_field(FID_INST_ID, $inst);
+ $resp .= add_field(FID_PATRON_ID, $patron_id);
+ $resp .= add_field(FID_ITEM_ID, $item_id);
+ $resp .= add_field(FID_TITLE_ID, $item->title_id);
+ $resp .= add_field(FID_DUE_DATE, $item->due_date);
+
+ $resp .= maybe_add(FID_SCREEN_MSG, $status->screen_msg);
+ $resp .= maybe_add(FID_PRINT_LINE, $status->print_line);
+
+ if ($protocol_version >= 2) {
+ if ($ils->supports('security inhibit')) {
+ $resp .= add_field(FID_SECURITY_INHIBIT,
+ $status->security_inhibit);
+ }
+ $resp .= maybe_add(FID_MEDIA_TYPE, $item->sip_media_type);
+ $resp .= maybe_add(FID_ITEM_PROPS, $item->sip_item_properties);
+
+ # Financials
+ if ($status->fee_amount) {
+ $resp .= add_field(FID_FEE_AMT, $status->fee_amount);
+ $resp .= maybe_add(FID_CURRENCY, $status->sip_currency);
+ $resp .= maybe_add(FID_FEE_TYPE, $status->sip_fee_type);
+ $resp .= maybe_add(FID_TRANSACTION_ID,
+ $status->transaction_id);
+ }
+ }
+
+ } else {
+ # Checkout failed
+ # Checkout Response: not ok, no renewal, don't know mag. media,
+ # no desensitize
+ $resp = sprintf("120NUN%s", Sip::timestamp);
+ $resp .= add_field(FID_INST_ID, $inst);
+ $resp .= add_field(FID_PATRON_ID, $patron_id);
+ $resp .= add_field(FID_ITEM_ID, $item_id);
+
+ # If the item is valid, provide the title, otherwise
+ # leave it blank
+ $resp .= add_field(FID_TITLE_ID, $item ? $item->title_id : '');
+ # Due date is required. Since it didn't get checked out,
+ # it's not due, so leave the date blank
+ $resp .= add_field(FID_DUE_DATE, '');
+
+ $resp .= maybe_add(FID_SCREEN_MSG, $status->screen_msg);
+ $resp .= maybe_add(FID_PRINT_LINE, $status->print_line);
+
+ if ($protocol_version >= 2) {
+ # Is the patron ID valid?
+ $resp .= add_field(FID_VALID_PATRON, sipbool($patron));
+
+ if ($patron && exists($fields->{FID_PATRON_PWD})) {
+ # Password provided, so we can tell if it was valid or not
+ $resp .= add_field(FID_VALID_PATRON_PWD,
+ sipbool($patron->check_password($fields->{(FID_PATRON_PWD)})));
+ }
+ }
+ }
+
+ $self->write_msg($resp);
+ return(CHECKOUT);
+}
+
+sub handle_checkin {
+ my ($self, $server) = @_;
+ my $account = $server->{account};
+ my $ils = $server->{ils};
+ my ($no_block, $trans_date, $return_date);
+ my $fields;
+ my ($current_loc, $inst_id, $item_id, $terminal_pwd, $item_props, $cancel);
+ my $resp = CHECKIN_RESP;
+ my ($patron, $item);
+ my $status;
+
+ ($no_block, $trans_date, $return_date) = @{$self->{fixed_fields}};
+ $fields = $self->{fields};
+
+ $current_loc = $fields->{(FID_CURRENT_LOCN)};
+ $inst_id = $fields->{(FID_INST_ID)};
+ $item_id = $fields->{(FID_ITEM_ID)};
+ $item_props = $fields->{(FID_ITEM_PROPS)};
+ $cancel = $fields->{(FID_CANCEL)};
+
+ $ils->check_inst_id($inst_id, "handle_checkin");
+
+ if ($no_block eq 'Y') {
+ # Off-line transactions, ick.
+ syslog("LOG_WARN", "received no-block checkin from terminal '%s'",
+ $account->{id});
+ $status = $ils->checkin_no_block($item_id, $trans_date,
+ $return_date, $item_props, $cancel);
+ } else {
+ $status = $ils->checkin($item_id, $trans_date, $return_date,
+ $current_loc, $item_props, $cancel);
+ }
+
+ $patron = $status->patron;
+ $item = $status->item;
+
+ $resp .= $status->ok ? '1' : '0';
+ $resp .= $status->resensitize ? 'Y' : 'N';
+ if ($item && $ils->supports('magnetic media')) {
+ $resp .= sipbool($item->magnetic);
+ } else {
+ # The item barcode was invalid or the system doesn't support
+ # the 'magnetic media' indicator
+ $resp .= 'U';
+ }
+ $resp .= $status->alert ? 'Y' : 'N';
+ $resp .= Sip::timestamp;
+ $resp .= add_field(FID_INST_ID, $inst_id);
+ $resp .= add_field(FID_ITEM_ID, $item_id);
+
+ if ($item) {
+ $resp .= add_field(FID_PERM_LOCN, $item->permanent_location);
+ $resp .= maybe_add(FID_TITLE_ID, $item->title_id);
+ }
+
+ if ($protocol_version >= 2) {
+ $resp .= maybe_add(FID_SORT_BIN, $status->sort_bin);
+ if ($patron) {
+ $resp .= add_field(FID_PATRON_ID, $patron->id);
+ }
+ if ($item) {
+ $resp .= maybe_add(FID_MEDIA_TYPE, $item->sip_media_type);
+ $resp .= maybe_add(FID_ITEM_PROPS, $item->sip_item_properties);
+ }
+ }
+
+ $resp .= maybe_add(FID_SCREEN_MSG, $status->screen_msg);
+ $resp .= maybe_add(FID_PRINT_LINE, $status->print_line);
+
+ $self->write_msg($resp);
+
+ return(CHECKIN);
+}
+
+sub handle_block_patron {
+ my ($self, $server) = @_;
+ my $account = $server->{account};
+ my $ils = $server->{ils};
+ my ($card_retained, $trans_date);
+ my ($inst_id, $blocked_card_msg, $patron_id, $terminal_pwd);
+ my $fields;
+ my $resp;
+ my $patron;
+
+ ($card_retained, $trans_date) = @{$self->{fixed_fields}};
+ $fields = $self->{fields};
+ $inst_id = $fields->{(FID_INST_ID)};
+ $blocked_card_msg = $fields->{(FID_BLOCKED_CARD_MSG)};
+ $patron_id = $fields->{(FID_PATRON_ID)};
+ $terminal_pwd = $fields->{(FID_TERMINAL_PWD)};
+
+ # Terminal passwords are different from account login
+ # passwords, but I have no idea what to do with them. So,
+ # I'll just ignore them for now.
+
+ $ils->check_inst_id($inst_id, "block_patron");
+
+ $patron = $ils->find_patron($patron_id);
+
+ # The correct response for a "Block Patron" message is a
+ # "Patron Status Response", so use that handler to generate
+ # the message, but then return the correct code from here.
+ #
+ # Normally, the language is provided by the "Patron Status"
+ # fixed field, but since we're not responding to one of those
+ # we'll just say, "Unspecified", as per the spec. Let the
+ # terminal default to something that, one hopes, will be
+ # intelligible
+ if ($patron) {
+ # Valid patron id
+ $patron->block($card_retained, $blocked_card_msg);
+ }
+
+ $resp = build_patron_status($patron, $patron->language, $fields);
+
+ $self->write_msg($resp);
+ return(BLOCK_PATRON);
+}
+
+sub handle_sc_status {
+ my ($self, $server) = @_;
+ my ($status, $print_width, $sc_protocol_version, $new_proto);
+
+ ($status, $print_width, $sc_protocol_version) = @{$self->{fixed_fields}};
+
+ if ($sc_protocol_version =~ /^1\./) {
+ $new_proto = 1;
+ } elsif ($sc_protocol_version =~ /^2\./) {
+ $new_proto = 2;
+ } else {
+ syslog("LOG_WARNING", "Unrecognized protocol revision '%s', falling back to '1'", $sc_protocol_version);
+ $new_proto = 1;
+ }
+
+ if ($new_proto != $protocol_version) {
+ syslog("LOG_INFO", "Setting protocol level to $new_proto");
+ $protocol_version = $new_proto;
+ }
+
+ if ($status == SC_STATUS_PAPER) {
+ syslog("LOG_WARN", "Self-Check unit '%s@%s' out of paper",
+ $self->{account}->{id}, $self->{account}->{institution});
+ } elsif ($status == SC_STATUS_SHUTDOWN) {
+ syslog("LOG_WARN", "Self-Check unit '%s@%s' shutting down",
+ $self->{account}->{id}, $self->{account}->{institution});
+ }
+
+ $self->{account}->{print_width} = $print_width;
+
+ return send_acs_status($self, $server) ? SC_STATUS : '';
+}
+
+sub handle_request_acs_resend {
+ my ($self, $server) = @_;
+
+ if (!$last_response) {
+ # We haven't sent anything yet, so respond with a
+ # REQUEST_SC_RESEND msg (p. 16)
+ $self->write_msg(REQUEST_SC_RESEND);
+ } elsif ((length($last_response) < 9)
+ || substr($last_response, -9, 2) ne 'AY') {
+ # When resending a message, we aren't supposed to include
+ # a sequence number, even if the original had one (p. 4).
+ # If the last message didn't have a sequence number, then
+ # we can just send it.
+ print("$last_response\r");
+ } else {
+ my $rebuilt;
+
+ # Cut out the sequence number and checksum, since the old
+ # checksum is wrong for the resent message.
+ $rebuilt = substr($last_response, 0, -9);
+ $self->write_msg($rebuilt);
+ }
+
+ return REQUEST_ACS_RESEND;
+}
+
+sub handle_login {
+ my ($self, $server) = @_;
+ my ($uid_algorithm, $pwd_algorithm);
+ my ($uid, $pwd);
+ my $inst;
+ my $fields;
+ my $status = 1; # Assume it all works
+
+ $fields = $self->{fields};
+ ($uid_algorithm, $pwd_algorithm) = @{$self->{fixed_fields}};
+
+ $uid = $fields->{(FID_LOGIN_UID)};
+ $pwd = $fields->{(FID_LOGIN_PWD)};
+
+ if ($uid_algorithm || $pwd_algorithm) {
+ syslog("LOG_ERR", "LOGIN: Can't cope with non-zero encryption methods: uid = $uid_algorithm, pwd = $pwd_algorithm");
+ $status = 0;
+ }
+
+ if (!exists($server->{config}->{accounts}->{$uid})) {
+ syslog("LOG_WARNING", "MsgType::handle_login: Unknown login '$uid'");
+ $status = 0;
+ } elsif ($server->{config}->{accounts}->{$uid}->{password} ne $pwd) {
+ syslog("LOG_WARNING",
+ "MsgType::handle_login: Invalid password for login '$uid'");
+ $status = 0;
+ } else {
+ # Store the active account someplace handy for everybody else to find.
+ $server->{account} = $server->{config}->{accounts}->{$uid};
+ $inst = $server->{account}->{institution};
+ $server->{institution} = $server->{config}->{institutions}->{$inst};
+ $server->{policy} = $server->{institution}->{policy};
+
+
+ syslog("LOG_INFO", "Successful login for '%s' of '%s'",
+ $server->{account}->{id}, $inst);
+ #
+ # initialize connection to ILS
+ #
+ my $module = $server->{config}
+ ->{institutions}
+ ->{ $inst }
+ ->{implementation};
+ $module->use;
+
+ if ($@) {
+ syslog("LOG_ERR", "%s: Loading ILS implementation '%s' for institution '%s' failed",
+ $server->{service}, $module, $inst);
+ die("Failed to load ILS implementation '$module'");
+ }
+
+ $server->{ils} = $module->new($server->{institution}, $server->{account});
+
+ if (!$server->{ils}) {
+ syslog("LOG_ERR", "%s: ILS connection to '%s' failed",
+ $server->{service}, $inst);
+ die("Unable to connect to ILS '$inst'");
+ }
+ }
+
+ $self->write_msg(LOGIN_RESP . $status);
+
+ return $status ? LOGIN : '';
+}
+
+#
+# Build the detailed summary information for the Patron
+# Information Response message based on the first 'Y' that appears
+# in the 'summary' field of the Patron Information reqest. The
+# specification says that only one 'Y' can appear in that field,
+# and we're going to believe it.
+#
+sub summary_info {
+ my ($ils, $patron, $summary, $start, $end) = @_;
+ my $resp = '';
+ my $itemlist;
+ my $summary_type;
+ my ($func, $fid);
+ #
+ # Map from offsets in the "summary" field of the Patron Information
+ # message to the corresponding field and handler
+ #
+ my @summary_map = (
+ { func => $patron->can("hold_items"),
+ fid => FID_HOLD_ITEMS },
+ { func => $patron->can("overdue_items"),
+ fid => FID_OVERDUE_ITEMS },
+ { func => $patron->can("charged_items"),
+ fid => FID_CHARGED_ITEMS },
+ { func => $patron->can("fine_items"),
+ fid => FID_FINE_ITEMS },
+ { func => $patron->can("recall_items"),
+ fid => FID_RECALL_ITEMS },
+ { func => $patron->can("unavail_holds"),
+ fid => FID_UNAVAILABLE_HOLD_ITEMS },
+ );
+
+
+ if (($summary_type = index($summary, 'Y')) == -1) {
+ # No detailed information required
+ return '';
+ }
+
+ syslog("LOG_DEBUG", "Summary_info: index == '%d', field '%s'",
+ $summary_type, $summary_map[$summary_type]->{fid});
+
+ $func = $summary_map[$summary_type]->{func};
+ $fid = $summary_map[$summary_type]->{fid};
+ $itemlist = &$func($patron, $start, $end);
+
+ syslog("LOG_DEBUG", "summary_info: list = (%s)", join(", ", @{$itemlist}));
+ foreach my $i (@{$itemlist}) {
+ $resp .= add_field($fid, $i);
+ }
+
+ return $resp;
+}
+
+sub handle_patron_info {
+ my ($self, $server) = @_;
+ my $ils = $server->{ils};
+ my ($lang, $trans_date, $summary) = @{$self->{fixed_fields}};
+ my $fields = $self->{fields};
+ my ($inst_id, $patron_id, $terminal_pwd, $patron_pwd, $start, $end);
+ my ($resp, $patron, $count);
+
+ $inst_id = $fields->{(FID_INST_ID)};
+ $patron_id = $fields->{(FID_PATRON_ID)};
+ $terminal_pwd = $fields->{(FID_TERMINAL_PWD)};
+ $patron_pwd = $fields->{(FID_PATRON_PWD)};
+ $start = $fields->{(FID_START_ITEM)};
+ $end = $fields->{(FID_END_ITEM)};
+
+ $patron = $ils->find_patron($patron_id);
+
+ $resp = (PATRON_INFO_RESP);
+ if ($patron) {
+ $resp .= patron_status_string($patron);
+ $resp .= $lang . Sip::timestamp();
+
+ $resp .= add_count('patron_info/hold_items',
+ scalar @{$patron->hold_items});
+ $resp .= add_count('patron_info/overdue_items',
+ scalar @{$patron->overdue_items});
+ $resp .= add_count('patron_info/charged_items',
+ scalar @{$patron->charged_items});
+ $resp .= add_count('patron_info/fine_items',
+ scalar @{$patron->fine_items});
+ $resp .= add_count('patron_info/recall_items',
+ scalar @{$patron->recall_items});
+ $resp .= add_count('patron_info/unavail_holds',
+ scalar @{$patron->unavail_holds});
+
+ # while the patron ID we got from the SC is valid, let's
+ # use the one returned from the ILS, just in case...
+ $resp .= add_field(FID_PATRON_ID, $patron->id);
+
+ $resp .= add_field(FID_PERSONAL_NAME, $patron->name);
+
+ # TODO: add code for the fields
+ # hold items limit
+ # overdue items limit
+ # charged items limit
+ # fee limit
+
+ $resp .= maybe_add(FID_CURRENCY, $patron->currency);
+ $resp .= maybe_add(FID_FEE_AMT, $patron->fee_amount);
+
+ $resp .= maybe_add(FID_HOME_ADDR,$patron->address);
+ $resp .= maybe_add(FID_EMAIL, $patron->email_addr);
+ $resp .= maybe_add(FID_HOME_PHONE, $patron->home_phone);
+
+ $resp .= summary_info($ils, $patron, $summary, $start, $end);
+
+ $resp .= add_field(FID_VALID_PATRON, 'Y');
+ if (defined($patron_pwd)) {
+ # If the patron password was provided, report on if
+ # it was right.
+ $resp .= add_field(FID_VALID_PATRON_PWD,
+ sipbool($patron->check_password($patron_pwd)));
+ }
+
+ # SIP 2.0 extensions used by Envisionware
+ # Other types of terminals will ignore the fields, if
+ # they don't recognize the codes
+ $resp .= maybe_add(FID_PATRON_BIRTHDATE, $patron->sip_birthdate);
+ $resp .= maybe_add(FID_PATRON_CLASS, $patron->ptype);
+
+ # Custom protocol extension to report patron internet privileges
+ $resp .= maybe_add(FID_INET_PROFILE, $patron->inet_privileges);
+
+ $resp .= maybe_add(FID_SCREEN_MSG, $patron->screen_msg);
+ $resp .= maybe_add(FID_PRINT_LINE, $patron->print_line);
+ } else {
+ # Invalid patron ID
+ # He has no privileges, no items associated with him,
+ # no personal name, and is invalid (if we're using 2.00)
+ $resp .= 'YYYY' . (' ' x 10) . $lang . Sip::timestamp();
+ $resp .= '0000' x 6;
+ $resp .= add_field(FID_PERSONAL_NAME, '');
+
+ # the patron ID is invalid, but it's a required field, so
+ # just echo it back
+ $resp .= add_field(FID_PATRON_ID, $fields->{(FID_PATRON_ID)});
+
+ if ($protocol_version >= 2) {
+ $resp .= add_field(FID_VALID_PATRON, 'N');
+ }
+ }
+
+ $resp .= add_field(FID_INST_ID, $server->{ils}->institution);
+
+ $self->write_msg($resp);
+
+ return(PATRON_INFO);
+}
+
+sub handle_end_patron_session {
+ my ($self, $server) = @_;
+ my $ils = $server->{ils};
+ my $trans_date;
+ my $fields = $self->{fields};
+ my $resp = END_SESSION_RESP;
+ my ($status, $screen_msg, $print_line);
+
+ ($trans_date) = @{$self->{fixed_fields}};
+
+ $ils->check_inst_id($fields->{FID_INST_ID}, "handle_end_patron_session");
+
+ ($status, $screen_msg, $print_line) = $ils->end_patron_session($fields->{(FID_PATRON_ID)});
+
+ $resp .= $status ? 'Y' : 'N';
+ $resp .= Sip::timestamp();
+
+ $resp .= add_field(FID_INST_ID, $server->{ils}->institution);
+ $resp .= add_field(FID_PATRON_ID, $fields->{(FID_PATRON_ID)});
+
+ $resp .= maybe_add(FID_SCREEN_MSG, $screen_msg);
+ $resp .= maybe_add(FID_PRINT_LINE, $print_line);
+
+ $self->write_msg($resp);
+
+ return(END_PATRON_SESSION);
+}
+
+sub handle_fee_paid {
+ my ($self, $server) = @_;
+ my $ils = $server->{ils};
+ my ($trans_date, $fee_type, $pay_type, $currency) = $self->{fixed_fields};
+ my $fields = $self->{fields};
+ my ($fee_amt, $inst_id, $patron_id, $terminal_pwd, $patron_pwd);
+ my ($fee_id, $trans_id);
+ my $status;
+ my $resp = FEE_PAID_RESP;
+
+ $fee_amt = $fields->{(FID_FEE_AMT)};
+ $inst_id = $fields->{(FID_INST_ID)};
+ $patron_id = $fields->{(FID_PATRON_ID)};
+ $patron_pwd = $fields->{(FID_PATRON_PWD)};
+ $fee_id = $fields->{(FID_FEE_ID)};
+ $trans_id = $fields->{(FID_TRANSACTION_ID)};
+
+ $ils->check_inst_id($inst_id, "handle_fee_paid");
+
+ $status = $ils->pay_fee($patron_id, $patron_pwd, $fee_amt, $fee_type,
+ $pay_type, $fee_id, $trans_id, $currency);
+
+ $resp .= ($status->ok ? 'Y' : 'N') . Sip::timestamp;
+ $resp .= add_field(FID_INST_ID, $inst_id);
+ $resp .= add_field(FID_PATRON_ID, $patron_id);
+ $resp .= maybe_add(FID_TRANSACTION_ID, $status->transaction_id);
+ $resp .= maybe_add(FID_SCREEN_MSG, $status->screen_msg);
+ $resp .= maybe_add(FID_PRINT_LINE, $status->print_line);
+
+ $self->write_msg($resp);
+
+ return(FEE_PAID);
+}
+
+sub handle_item_information {
+ my ($self, $server) = @_;
+ my $ils = $server->{ils};
+ my $trans_date;
+ my $fields = $self->{fields};
+ my $resp = ITEM_INFO_RESP;
+ my $item;
+ my $i;
+
+ ($trans_date) = @{$self->{fixed_fields}};
+
+ $ils->check_inst_id($fields->{(FID_INST_ID)}, "handle_item_information");
+
+ $item = $ils->find_item($fields->{(FID_ITEM_ID)});
+
+ if (!defined($item)) {
+ # Invalid Item ID
+ # "Other" circ stat, "Other" security marker, "Unknown" fee type
+ $resp .= "010101";
+ $resp .= Sip::timestamp;
+ # Just echo back the invalid item id
+ $resp .= add_field(FID_ITEM_ID, $fields->{(FID_ITEM_ID)});
+ # title id is required, but we don't have one
+ $resp .= add_field(FID_TITLE_ID, '');
+ } else {
+ # Valid Item ID, send the good stuff
+ $resp .= $item->sip_circulation_status;
+ $resp .= $item->sip_security_marker;
+ $resp .= $item->sip_fee_type;
+ $resp .= Sip::timestamp;
+
+ $resp .= add_field(FID_ITEM_ID, $item->id);
+ $resp .= add_field(FID_TITLE_ID, $item->title_id);
+
+ $resp .= maybe_add(FID_MEDIA_TYPE, $item->sip_media_type);
+ $resp .= maybe_add(FID_PERM_LOCN, $item->permanent_location);
+ $resp .= maybe_add(FID_CURRENT_LOCN, $item->current_location);
+ $resp .= maybe_add(FID_ITEM_PROPS, $item->sip_item_properties);
+
+ if (($i = $item->fee) != 0) {
+ $resp .= add_field(FID_CURRENCY, $item->fee_currency);
+ $resp .= add_field(FID_FEE_AMT, $i);
+ }
+ $resp .= maybe_add(FID_OWNER, $item->owner);
+
+ if (($i = scalar @{$item->hold_queue}) > 0) {
+ $resp .= add_field(FID_HOLD_QUEUE_LEN, $i);
+ }
+ if (($i = $item->due_date) != 0) {
+ $resp .= add_field(FID_DUE_DATE, Sip::timestamp($i));
+ }
+ if (($i = $item->recall_date) != 0) {
+ $resp .= add_field(FID_RECALL_DATE, Sip::timestamp($i));
+ }
+ if (($i = $item->hold_pickup_date) != 0) {
+ $resp .= add_field(FID_HOLD_PICKUP_DATE, Sip::timestamp($i));
+ }
+
+ $resp .= maybe_add(FID_SCREEN_MSG, $item->screen_msg);
+ $resp .= maybe_add(FID_PRINT_LINE, $item->print_line);
+ }
+
+ $self->write_msg($resp);
+
+ return(ITEM_INFORMATION);
+}
+
+sub handle_item_status_update {
+ my ($self, $server) = @_;
+ my $ils = $server->{ils};
+ my ($trans_date, $item_id, $terminal_pwd, $item_props);
+ my $fields = $self->{fields};
+ my $status;
+ my $item;
+ my $resp = ITEM_STATUS_UPDATE_RESP;
+
+ ($trans_date) = @{$self->{fixed_fields}};
+
+ $ils->check_inst_id($fields->{(FID_INST_ID)});
+
+ $item_id = $fields->{(FID_ITEM_ID)};
+ $item_props = $fields->{(FID_ITEM_PROPS)};
+
+ if (!defined($item_id)) {
+ syslog("LOG_WARNING",
+ "handle_item_status: received message without Item ID field");
+ } else {
+ $item = $ils->find_item($item_id);
+ }
+
+ if (!$item) {
+ # Invalid Item ID
+ $resp .= '0';
+ $resp .= Sip::timestamp;
+ $resp .= add_field(FID_ITEM_ID, $item_id);
+ } else {
+ # Valid Item ID
+
+ $status = $item->status_update($item_props);
+
+ $resp .= $status->ok ? '1' : '0';
+ $resp .= Sip::timestamp;
+
+ $resp .= add_field(FID_ITEM_ID, $item->id);
+ $resp .= add_field(FID_TITLE_ID, $item->title_id);
+ $resp .= maybe_add(FID_ITEM_PROPS, $item->sip_item_properties);
+ }
+
+ $resp .= maybe_add(FID_SCREEN_MSG, $status->screen_msg);
+ $resp .= maybe_add(FID_PRINT_LINE, $status->print_line);
+
+ $self->write_msg($resp);
+
+ return(ITEM_STATUS_UPDATE);
+}
+
+sub handle_patron_enable {
+ my ($self, $server) = @_;
+ my $ils = $server->{ils};
+ my $fields = $self->{fields};
+ my ($trans_date, $patron_id, $terminal_pwd, $patron_pwd);
+ my ($status, $patron);
+ my $resp = PATRON_ENABLE_RESP;
+
+ ($trans_date) = @{$self->{fixed_fields}};
+ $patron_id = $fields->{(FID_PATRON_ID)};
+ $patron_pwd = $fields->{(FID_PATRON_PWD)};
+
+ syslog("LOG_DEBUG", "handle_patron_enable: patron_id: '%s', patron_pwd: '%s'",
+ $patron_id, $patron_pwd);
+
+ $patron = $ils->find_patron($patron_id);
+
+ if (!defined($patron)) {
+ # Invalid patron ID
+ $resp .= 'YYYY' . (' ' x 10) . '000' . Sip::timestamp();
+ $resp .= add_field(FID_PATRON_ID, $patron_id);
+ $resp .= add_field(FID_PERSONAL_NAME, '');
+ $resp .= add_field(FID_VALID_PATRON, 'N');
+ $resp .= add_field(FID_VALID_PATRON_PWD, 'N');
+ } else {
+ # valid patron
+ if (!defined($patron_pwd) || $patron->check_password($patron_pwd)) {
+ # Don't enable the patron if there was an invalid password
+ $status = $patron->enable;
+ }
+ $resp .= patron_status_string($patron);
+ $resp .= $patron->language . Sip::timestamp();
+
+ $resp .= add_field(FID_PATRON_ID, $patron->id);
+ $resp .= add_field(FID_PERSONAL_NAME, $patron->name);
+ if (defined($patron_pwd)) {
+ $resp .= add_field(FID_VALID_PATRON_PWD,
+ sipbool($patron->check_password($patron_pwd)));
+ }
+ $resp .= add_field(FID_VALID_PATRON, 'Y');
+ $resp .= maybe_add(FID_SCREEN_MSG, $patron->screen_msg);
+ $resp .= maybe_add(FID_PRINT_LINE, $patron->print_line);
+ }
+
+ $resp .= add_field(FID_INST_ID, $ils->institution);
+
+ $self->write_msg($resp);
+
+ return(PATRON_ENABLE);
+}
+
+sub handle_hold {
+ my ($self, $server) = @_;
+ my $ils = $server->{ils};
+ my ($hold_mode, $trans_date);
+ my ($expiry_date, $pickup_locn, $hold_type, $patron_id, $patron_pwd);
+ my ($item_id, $title_id, $fee_ack);
+ my $fields = $self->{fields};
+ my $status;
+ my $resp = HOLD_RESP;
+
+ ($hold_mode, $trans_date) = @{$self->{fixed_fields}};
+
+ $ils->check_inst_id($fields->{(FID_INST_ID)}, "handle_hold");
+
+ $patron_id = $fields->{(FID_PATRON_ID)};
+ $expiry_date = $fields->{(FID_EXPIRATION)} || '';
+ $pickup_locn = $fields->{(FID_PICKUP_LOCN)} || '';
+ $hold_type = $fields->{(FID_HOLD_TYPE)} || '2'; # Any copy of title
+ $patron_pwd = $fields->{(FID_PATRON_PWD)};
+ $item_id = $fields->{(FID_ITEM_ID)} || '';
+ $title_id = $fields->{(FID_TITLE_ID)} || '';
+ $fee_ack = $fields->{(FID_FEE_ACK)} || 'N';
+
+ if ($hold_mode eq '+') {
+ $status = $ils->add_hold($patron_id, $patron_pwd,
+ $item_id, $title_id,
+ $expiry_date, $pickup_locn, $hold_type,
+ $fee_ack);
+ } elsif ($hold_mode eq '-') {
+ $status = $ils->cancel_hold($patron_id, $patron_pwd,
+ $item_id, $title_id);
+ } elsif ($hold_mode eq '*') {
+ $status = $ils->alter_hold($patron_id, $patron_pwd,
+ $item_id, $title_id,
+ $expiry_date, $pickup_locn, $hold_type,
+ $fee_ack);
+ } else {
+ syslog("LOG_WARNING", "handle_hold: Unrecognized hold mode '%s' from terminal '%s'",
+ $hold_mode, $server->{account}->{id});
+ $status = $ils->Transaction::Hold;
+ $status->screen_msg("System error. Please contact library status");
+ }
+
+ $resp .= $status->ok;
+ $resp .= sipbool($status->item && $status->item->available($patron_id));
+ $resp .= Sip::timestamp;
+
+ if ($status->ok) {
+ $resp .= add_field(FID_PATRON_ID, $status->patron->id);
+
+ if ($status->expiration_date) {
+ $resp .= maybe_add(FID_EXPIRATION,
+ Sip::timestamp($status->expiration_date));
+ }
+ $resp .= maybe_add(FID_QUEUE_POS, $status->queue_position);
+ $resp .= maybe_add(FID_PICKUP_LOCN, $status->pickup_location);
+ $resp .= maybe_add(FID_ITEM_ID, $status->item->id);
+ $resp .= maybe_add(FID_TITLE_ID, $status->item->title_id);
+ } else {
+ # Not ok. still need required fields
+ $resp .= add_field(FID_PATRON_ID, $patron_id);
+ }
+
+ $resp .= add_field(FID_INST_ID, $ils->institution);
+ $resp .= maybe_add(FID_SCREEN_MSG, $status->screen_msg);
+ $resp .= maybe_add(FID_PRINT_LINE, $status->print_line);
+
+ $self->write_msg($resp);
+
+ return(HOLD);
+}
+
+sub handle_renew {
+ my ($self, $server) = @_;
+ my $ils = $server->{ils};
+ my ($third_party, $no_block, $trans_date, $nb_due_date);
+ my ($patron_id, $patron_pwd, $item_id, $title_id, $item_props, $fee_ack);
+ my $fields = $self->{fields};
+ my $status;
+ my ($patron, $item);
+ my $resp = RENEW_RESP;
+
+ ($third_party, $no_block, $trans_date, $nb_due_date) =
+ @{$self->{fixed_fields}};
+
+ $ils->check_inst_id($fields->{(FID_INST_ID)}, "handle_renew");
+
+ if ($no_block eq 'Y') {
+ syslog("LOG_WARNING",
+ "handle_renew: recieved 'no block' renewal from terminal '%s'",
+ $server->{account}->{id});
+ }
+
+ $patron_id = $fields->{(FID_PATRON_ID)};
+ $patron_pwd = $fields->{(FID_PATRON_PWD)};
+ $item_id = $fields->{(FID_ITEM_ID)};
+ $title_id = $fields->{(FID_TITLE_ID)};
+ $item_props = $fields->{(FID_ITEM_PROPS)};
+ $fee_ack = $fields->{(FID_FEE_ACK)};
+
+ $status = $ils->renew($patron_id, $patron_pwd, $item_id, $title_id,
+ $no_block, $nb_due_date, $third_party,
+ $item_props, $fee_ack);
+
+ $patron = $status->patron;
+ $item = $status->item;
+
+ if ($status->ok) {
+ $resp .= '1';
+ $resp .= $status->renewal_ok ? 'Y' : 'N';
+ if ($ils->supports('magnetic media')) {
+ $resp .= sipbool($item->magnetic);
+ } else {
+ $resp .= 'U';
+ }
+ $resp .= sipbool($status->desensitize);
+ $resp .= Sip::timestamp;
+ $resp .= add_field(FID_PATRON_ID, $patron->id);
+ $resp .= add_field(FID_ITEM_ID, $item->id);
+ $resp .= add_field(FID_TITLE_ID, $item->title_id);
+ $resp .= add_field(FID_DUE_DATE, Sip::timestamp($item->due_date));
+ if ($ils->supports('security inhibit')) {
+ $resp .= add_field(FID_SECURITY_INHIBIT,
+ $status->security_inhibit);
+ }
+ $resp .= add_field(FID_MEDIA_TYPE, $item->sip_media_type);
+ $resp .= maybe_add(FID_ITEM_PROPS, $item->sip_item_properties);
+ } else {
+ # renew failed for some reason
+ # not OK, renewal not OK, Unknown media type (why bother checking?)
+ $resp .= '0NUN';
+ $resp .= Sip::timestamp;
+ # If we found the patron or the item, the return the ILS
+ # information, otherwise echo back the infomation we received
+ # from the terminal
+ $resp .= add_field(FID_PATRON_ID, $patron ? $patron->id : $patron_id);
+ $resp .= add_field(FID_ITEM_ID, $item ? $item->id : $item_id);
+ $resp .= add_field(FID_TITLE_ID, $item ? $item->title_id : $title_id);
+ $resp .= add_field(FID_DUE_DATE, '');
+ }
+
+ if ($status->fee_amount) {
+ $resp .= add_field(FID_FEE_AMT, $status->fee_amount);
+ $resp .= maybe_add(FID_CURRENCY, $status->sip_currency);
+ $resp .= maybe_add(FID_FEE_TYPE, $status->sip_fee_type);
+ $resp .= maybe_add(FID_TRANSACTION_ID, $status->transaction_id);
+ }
+
+ $resp .= add_field(FID_INST_ID, $ils->institution);
+ $resp .= maybe_add(FID_SCREEN_MSG, $status->screen_msg);
+ $resp .= maybe_add(FID_PRINT_LINE, $status->print_line);
+
+ $self->write_msg($resp);
+
+ return(RENEW);
+}
+
+sub handle_renew_all {
+ my ($self, $server) = @_;
+ my $ils = $server->{ils};
+ my ($trans_date, $patron_id, $patron_pwd, $terminal_pwd, $fee_ack);
+ my $fields = $self->{fields};
+ my $resp = RENEW_ALL_RESP;
+ my $status;
+ my (@renewed, @unrenewed);
+
+ $ils->check_inst_id($fields->{(FID_INST_ID)}, "handle_renew_all");
+
+ ($trans_date) = @{$self->{fixed_fields}};
+
+ $patron_id = $fields->{(FID_PATRON_ID)};
+ $patron_pwd = $fields->{(FID_PATRON_PWD)};
+ $terminal_pwd = $fields->{(FID_TERMINAL_PWD)};
+ $fee_ack = $fields->{(FID_FEE_ACK)};
+
+ $status = $ils->renew_all($patron_id, $patron_pwd, $fee_ack);
+
+ $resp .= $status->ok ? '1' : '0';
+
+ if (!$status->ok) {
+ $resp .= add_count("renew_all/renewed_count", 0);
+ $resp .= add_count("renew_all/unrenewed_count", 0);
+ @renewed = [];
+ @unrenewed = [];
+ } else {
+ @renewed = @{$status->renewed};
+ @unrenewed = @{$status->unrenewed};
+ $resp .= add_count("renew_all/renewed_count", scalar @renewed);
+ $resp .= add_count("renew_all/unrenewed_count", scalar @unrenewed);
+ }
+
+ $resp .= Sip::timestamp;
+ $resp .= add_field(FID_INST_ID, $ils->institution);
+
+ $resp .= join('', map(add_field(FID_RENEWED_ITEMS, $_), @renewed));
+ $resp .= join('', map(add_field(FID_UNRENEWED_ITEMS, $_), @unrenewed));
+
+ $resp .= maybe_add(FID_SCREEN_MSG, $status->screen_msg);
+ $resp .= maybe_add(FID_PRINT_LINE, $status->print_line);
+
+ $self->write_msg($resp);
+
+ return(RENEW_ALL);
+}
+
+#
+# send_acs_status($self, $server)
+#
+# Send an ACS Status message, which is contains lots of little fields
+# of information gleaned from all sorts of places.
+#
+
+my @message_type_names = (
+ "patron status request",
+ "checkout",
+ "checkin",
+ "block patron",
+ "acs status",
+ "request sc/acs resend",
+ "login",
+ "patron information",
+ "end patron session",
+ "fee paid",
+ "item information",
+ "item status update",
+ "patron enable",
+ "hold",
+ "renew",
+ "renew all",
+ );
+
+sub send_acs_status {
+ my ($self, $server, $screen_msg, $print_line) = @_;
+ my $msg = ACS_STATUS;
+ my $account = $server->{account};
+ my $policy = $server->{policy};
+ my $ils = $server->{ils};
+ my ($online_status, $checkin_ok, $checkout_ok, $ACS_renewal_policy);
+ my ($status_update_ok, $offline_ok, $timeout, $retries);
+
+ $online_status = 'Y';
+ $checkout_ok = sipbool($ils->checkout_ok);
+ $checkin_ok = sipbool($ils->checkin_ok);
+ $ACS_renewal_policy = sipbool($policy->{renewal});
+ $status_update_ok = sipbool($ils->status_update_ok);
+ $offline_ok = sipbool($ils->offline_ok);
+ $timeout = sprintf("%03d", $policy->{timeout});
+ $retries = sprintf("%03d", $policy->{retries});
+
+ if (length($timeout) != 3) {
+ syslog("LOG_ERR", "handle_acs_status: timeout field wrong size: '%s'",
+ $timeout);
+ $timeout = '000';
+ }
+
+ if (length($retries) != 3) {
+ syslog("LOG_ERR", "handle_acs_status: retries field wrong size: '%s'",
+ $retries);
+ $retries = '000';
+ }
+
+ $msg .= "$online_status$checkin_ok$checkout_ok$ACS_renewal_policy";
+ $msg .= "$status_update_ok$offline_ok$timeout$retries";
+ $msg .= Sip::timestamp();
+
+ if ($protocol_version == 1) {
+ $msg .= '1.00';
+ } elsif ($protocol_version == 2) {
+ $msg .= '2.00';
+ } else {
+ syslog("LOG_ERROR",
+ 'Bad setting for $protocol_version, "%s" in send_acs_status',
+ $protocol_version);
+ $msg .= '1.00';
+ }
+
+ # Institution ID
+ $msg .= add_field(FID_INST_ID, $account->{institution});
+
+ if ($protocol_version >= 2) {
+ # Supported messages: we do it all
+ my $supported_msgs = '';
+
+ foreach my $msg_name (@message_type_names) {
+ if ($msg_name eq 'request sc/acs resend') {
+ $supported_msgs .= Sip::sipbool(1);
+ } else {
+ $supported_msgs .= Sip::sipbool($ils->supports($msg_name));
+ }
+ }
+ if (length($supported_msgs) < 16) {
+ syslog("LOG_ERROR", 'send_acs_status: supported messages "%s" too short', $supported_msgs);
+ }
+ $msg .= add_field(FID_SUPPORTED_MSGS, $supported_msgs);
+ }
+
+ $msg .= maybe_add(FID_SCREEN_MSG, $screen_msg);
+
+ if (defined($account->{print_width}) && defined($print_line)
+ && $account->{print_width} < length($print_line)) {
+ syslog("LOG_WARNING", "send_acs_status: print line '%s' too long. Truncating",
+ $print_line);
+ $print_line = substr($print_line, 0, $account->{print_width});
+ }
+
+ $msg .= maybe_add(FID_PRINT_LINE, $print_line);
+
+ # Do we want to tell the terminal its location?
+
+ $self->write_msg($msg);
+ return 1;
+}
+
+#
+# build_patron_status: create the 14-char patron status
+# string for the Patron Status message
+#
+sub patron_status_string {
+ my $patron = shift;
+ my $patron_status;
+
+ syslog("LOG_DEBUG", "patron_status_string: %s charge_ok: %s", $patron->id,
+ $patron->charge_ok);
+ $patron_status = sprintf('%s%s%s%s%s%s%s%s%s%s%s%s%s%s',
+ denied($patron->charge_ok),
+ denied($patron->renew_ok),
+ denied($patron->recall_ok),
+ denied($patron->hold_ok),
+ boolspace($patron->card_lost),
+ boolspace($patron->too_many_charged),
+ boolspace($patron->too_many_overdue),
+ boolspace($patron->too_many_renewal),
+ boolspace($patron->too_many_claim_return),
+ boolspace($patron->too_many_lost),
+ boolspace($patron->excessive_fines),
+ boolspace($patron->excessive_fees),
+ boolspace($patron->recall_overdue),
+ boolspace($patron->too_many_billed));
+ return $patron_status;
+}
+
+1;
--- /dev/null
+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
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#
+#
+#
+
+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)
--- /dev/null
+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.
--- /dev/null
+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;
--- /dev/null
+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|
--- /dev/null
+#
+# 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);
--- /dev/null
+#
+# 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;
projects / koha.git / commitdiff