2 # ILS.pm: Test ILS interface module
6 use warnings; use strict;
8 use Sys::Syslog qw(syslog);
10 use OpenILS::SIP::Item;
11 use OpenILS::SIP::Patron;
12 use OpenILS::SIP::Transaction;
13 use OpenILS::SIP::Transaction::Checkout;
14 use OpenILS::SIP::Transaction::Checkin;
15 use OpenILS::SIP::Transaction::Renew;
18 use OpenILS::Utils::Fieldmapper;
19 use OpenSRF::Utils::SettingsClient;
20 use OpenILS::Application::AppUtils;
21 use OpenSRF::Utils qw/:datetime/;
22 use DateTime::Format::ISO8601;
24 use Unicode::Normalize;
25 my $U = 'OpenILS::Application::AppUtils';
31 use Digest::MD5 qw(md5_hex);
34 my ($class, $institution, $login) = @_;
35 my $type = ref($class) || $class;
38 $self->{login} = $login;
40 $config = $institution;
41 syslog("LOG_DEBUG", "OILS: new ILS '%s'", $institution->{id});
42 $self->{institution} = $institution;
44 my $bsconfig = $institution->{implementation_config}->{bootstrap};
45 $target_encoding = $institution->{implementation_config}->{encoding} || 'ascii';
47 syslog('LOG_DEBUG', "OILS: loading bootstrap config: $bsconfig");
49 local $/ = "\n"; # why?
50 OpenSRF::System->bootstrap_client(config_file => $bsconfig);
51 syslog('LOG_DEBUG', "OILS: bootstrap loaded..");
53 $self->{osrf_config} = OpenSRF::Utils::SettingsClient->new;
55 Fieldmapper->import($self->{osrf_config}->config_value('IDL'));
57 bless( $self, $type );
60 $self->login( $login->{id}, $login->{password} );
67 my $ses = $U->simplereq(
69 'open-ils.auth.session.retrieve', $self->{authtoken} );
70 return 1 unless $U->event_code($ses);
71 syslog('LOG_INFO', "OILS: Logging back after session timeout as user ".$self->{login}->{id});
72 return $self->login( $self->{login}->{id}, $self->{login}->{password} );
76 return $editor = make_editor();
84 # Creates the global editor object
85 my $cstore_init = 1; # call init on first use
87 OpenILS::Utils::CStoreEditor::init() if $cstore_init;
89 return OpenILS::Utils::CStoreEditor->new;
92 =head2 clean_text(scalar)
94 Evergreen uses the UTF8 encoding for everything from the database up. Perl
95 doesn't know this, however, so we have to convince it to treat our UTF8 strings
96 as UTF8 strings. This may enable OpenNCIP to correctly calculate the checksums
97 for UTF8 text for SIP clients that support such modern options.
99 The target encoding is set in the <encoding> element of the SIPServer.pm
105 my $text = shift || '';
107 # Convert our incoming UTF8 data into Perl's internal string format
109 # Also convert to Normalization Form D, as the ASCII, iso-8859-1,
110 # and latin-1 encodings (at least) require this to substitute
111 # characters rather than simply returning a string truncated
112 # after the first non-ASCII character
113 $text = NFD(decode_utf8($text));
115 if ($target_encoding eq 'ascii') {
117 # Try to maintain a reasonable version of the content by
118 # stripping diacritics from the text, given that the SIP client
119 # wants just plain ASCII. This is the base requirement according
120 # to the SIP2 specification.
122 # Stripping the combining characters converts ""béè♁ts"
123 # into "bee?ts" instead of "b???ts" - better, eh?
127 # Characters that cannot be represented in the target encoding will
128 # generally be replaced with a question mark (?) character.
129 $text = encode($target_encoding, $text);
137 my $type = shift || 'dob';
139 return "" unless $date;
141 $date = DateTime::Format::ISO8601->new->
142 parse_datetime(OpenSRF::Utils::cleanse_ISO8601($date));
143 my @time = localtime($date->epoch);
145 my $year = $time[5]+1900;
146 my $mon = $time[4]+1;
149 my $minute = $time[1];
150 my $second = $time[0];
152 $date = sprintf("%04d%02d%02d", $year, $mon, $day);
154 # Due dates need hyphen separators and time of day as well
155 if ($type eq 'due') {
156 $date = sprintf("%04d-%02d-%02d %02d:%02d:%02d", $year, $mon, $day, $hour, $minute, $second);
159 syslog('LOG_DEBUG', "OILS: formatted date [type=$type]: $date");
166 my( $self, $username, $password ) = @_;
167 syslog('LOG_DEBUG', "OILS: Logging in with username $username");
169 my $seed = $U->simplereq(
171 'open-ils.auth.authenticate.init', $username );
173 my $response = $U->simplereq(
175 'open-ils.auth.authenticate.complete',
177 username => $username,
178 password => md5_hex($seed . md5_hex($password)),
183 if( my $code = $U->event_code($response) ) {
184 my $txt = $response->{textcode};
185 syslog('LOG_WARNING', "OILS: Login failed for $username. $txt:$code");
189 my $key = $response->{payload}->{authtoken};
190 syslog('LOG_INFO', "OILS: Login succeeded for $username : authkey = $key");
191 return $self->{authtoken} = $key;
197 return OpenILS::SIP::Patron->new(@_);
203 return OpenILS::SIP::Item->new(@_);
209 return $self->{institution}->{id}; # consider making this return the whole institution
214 return $self->{institution}->{id}; # then use this for just the ID
218 my ($self, $op) = @_;
219 my ($i) = grep { $_->{name} eq $op }
220 @{$config->{implementation_config}->{supports}->{item}};
221 return to_bool($i->{value});
225 my ($self, $id, $whence) = @_;
226 if ($id ne $self->{institution}->{id}) {
227 syslog("LOG_WARNING", "OILS: %s: received institution '%s', expected '%s'", $whence, $id, $self->{institution}->{id});
228 # Just an FYI check, we don't expect the user to change location from that in SIPconfig.xml
235 # If it's defined, and matches a true sort of string, or is
236 # a non-zero number, then it's true.
237 defined($bool) or return; # false
238 ($bool =~ /true|y|yes/i) and return 1; # true
239 return ($bool =~ /^\d+$/ and $bool != 0); # true for non-zero numbers, false otherwise
243 return to_bool($config->{policy}->{checkout});
247 return to_bool($config->{policy}->{checkin});
251 return to_bool($config->{policy}->{renew});
254 sub status_update_ok {
255 return to_bool($config->{policy}->{status_update});
259 return to_bool($config->{policy}->{offline});
265 ## Checkout(patron_id, item_id, sc_renew):
266 ## patron_id & item_id are the identifiers send by the terminal
267 ## sc_renew is the renewal policy configured on the terminal
268 ## returns a status opject that can be queried for the various bits
269 ## of information that the protocol (SIP or NCIP) needs to generate
274 my ($self, $patron_id, $item_id, $sc_renew) = @_;
277 $self->verify_session;
279 syslog('LOG_DEBUG', "OILS: OpenILS::Checkout attempt: patron=$patron_id, item=$item_id");
281 my $xact = OpenILS::SIP::Transaction::Checkout->new( authtoken => $self->{authtoken} );
282 my $patron = $self->find_patron($patron_id);
283 my $item = $self->find_item($item_id);
285 $xact->patron($patron);
289 $xact->screen_msg("Invalid Patron");
293 if (!$patron->charge_ok) {
294 $xact->screen_msg("Patron Blocked");
299 $xact->screen_msg("Invalid Item");
303 syslog('LOG_DEBUG', "OILS: OpenILS::Checkout data loaded OK, checking out...");
305 if ($item->{patron} && ($item->{patron} eq $patron_id)) {
306 syslog('LOG_INFO', "OILS: OpenILS::Checkout data loaded OK, doing renew...");
308 } elsif ($item->{patron} && ($item->{patron} ne $patron_id)) {
309 # I can't deal with this right now
310 # XXX check in then check out?
311 $xact->screen_msg("Item checked out to another patron");
315 $xact->do_checkout($sc_renew);
316 $xact->desensitize(!$item->magnetic);
321 syslog("LOG_DEBUG", "OILS: OpenILS::Checkout: " .
322 "patron %s checkout %s succeeded", $patron_id, $item_id);
326 #editor()->xact_rollback;
327 syslog("LOG_DEBUG", "OILS: OpenILS::Checkout: " .
328 "patron %s checkout %s FAILED, rolling back xact...", $patron_id, $item_id);
336 my ($self, $item_id, $trans_date, $return_date,
337 $current_loc, $item_props, $cancel) = @_;
339 $self->verify_session;
341 syslog('LOG_DEBUG', "OILS: OpenILS::Checkin on item=$item_id");
344 my $xact = OpenILS::SIP::Transaction::Checkin->new(authtoken => $self->{authtoken});
345 my $item = $self->find_item($item_id);
350 $xact->screen_msg("Invalid item barcode: $item_id");
355 $xact->do_checkin( $trans_date, $return_date, $current_loc, $item_props );
358 $xact->patron($patron = $self->find_patron($item->{patron}));
359 delete $item->{patron};
360 delete $item->{due_date};
361 syslog('LOG_INFO', "OILS: Checkin succeeded");
364 #editor()->xact_rollback;
365 syslog('LOG_WARNING', "OILS: Checkin failed");
372 ## If the ILS caches patron information, this lets it free it up.
373 ## Also, this could be used for centrally logging session duration.
374 ## We don't do anything with it.
375 sub end_patron_session {
376 my ($self, $patron_id) = @_;
377 return (1, 'Thank you for using OpenILS!', '');
382 # my ($self, $patron_id, $patron_pwd, $fee_amt, $fee_type,
383 # $pay_type, $fee_id, $trans_id, $currency) = @_;
387 # $trans = new ILS::Transaction::FeePayment;
389 # $patron = new ILS::Patron $patron_id;
391 # $trans->transaction_id($trans_id);
392 # $trans->patron($patron);
399 # my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
400 # $expiry_date, $pickup_location, $hold_type, $fee_ack) = @_;
401 # my ($patron, $item);
406 # $trans = new ILS::Transaction::Hold;
408 # # BEGIN TRANSACTION
409 # $patron = new ILS::Patron $patron_id;
411 # || (defined($patron_pwd) && !$patron->check_password($patron_pwd))) {
412 # $trans->screen_msg("Invalid Patron.");
417 # $item = new ILS::Item ($item_id || $title_id);
419 # $trans->screen_msg("No such item.");
421 # # END TRANSACTION (conditionally)
423 # } elsif ($item->fee && ($fee_ack ne 'Y')) {
424 # $trans->screen_msg = "Fee required to place hold.";
426 # # END TRANSACTION (conditionally)
431 # item_id => $item->id,
432 # patron_id => $patron->id,
433 # expiration_date => $expiry_date,
434 # pickup_location => $pickup_location,
435 # hold_type => $hold_type,
439 # $trans->patron($patron);
440 # $trans->item($item);
441 # $trans->pickup_location($pickup_location);
443 # push(@{$item->hold_queue}, $hold);
444 # push(@{$patron->{hold_items}}, $hold);
452 # my ($self, $patron_id, $patron_pwd, $item_id, $title_id) = @_;
453 # my ($patron, $item, $hold);
456 # $trans = new ILS::Transaction::Hold;
458 # # BEGIN TRANSACTION
459 # $patron = new ILS::Patron $patron_id;
461 # $trans->screen_msg("Invalid patron barcode.");
464 # } elsif (defined($patron_pwd) && !$patron->check_password($patron_pwd)) {
465 # $trans->screen_msg('Invalid patron password.');
470 # $item = new ILS::Item ($item_id || $title_id);
472 # $trans->screen_msg("No such item.");
474 # # END TRANSACTION (conditionally)
478 # # Remove the hold from the patron's record first
479 # $trans->ok($patron->drop_hold($item_id));
482 # # We didn't find it on the patron record
483 # $trans->screen_msg("No such hold on patron record.");
485 # # END TRANSACTION (conditionally)
489 # # Now, remove it from the item record. If it was on the patron
490 # # record but not on the item record, we'll treat that as success.
491 # foreach my $i (0 .. scalar @{$item->hold_queue}) {
492 # $hold = $item->hold_queue->[$i];
494 # if ($hold->{patron_id} eq $patron->id) {
495 # # found it: delete it.
496 # splice @{$item->hold_queue}, $i, 1;
501 # $trans->screen_msg("Hold Cancelled.");
502 # $trans->patron($patron);
503 # $trans->item($item);
509 ## The patron and item id's can't be altered, but the
510 ## date, location, and type can.
512 # my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
513 # $expiry_date, $pickup_location, $hold_type, $fee_ack) = @_;
514 # my ($patron, $item);
518 # $trans = new ILS::Transaction::Hold;
520 # # BEGIN TRANSACTION
521 # $patron = new ILS::Patron $patron_id;
523 # $trans->screen_msg("Invalid patron barcode.");
528 # foreach my $i (0 .. scalar @{$patron->{hold_items}}) {
529 # $hold = $patron->{hold_items}[$i];
531 # if ($hold->{item_id} eq $item_id) {
532 # # Found it. So fix it.
533 # $hold->{expiration_date} = $expiry_date if $expiry_date;
534 # $hold->{pickup_location} = $pickup_location if $pickup_location;
535 # $hold->{hold_type} = $hold_type if $hold_type;
538 # $trans->screen_msg("Hold updated.");
539 # $trans->patron($patron);
540 # $trans->item(new ILS::Item $hold->{item_id});
545 # # The same hold structure is linked into both the patron's
546 # # list of hold items and into the queue of outstanding holds
547 # # for the item, so we don't need to search the hold queue for
548 # # the item, since it's already been updated by the patron code.
551 # $trans->screen_msg("No such outstanding hold.");
559 my ($self, $patron_id, $patron_pwd, $item_id, $title_id,
560 $no_block, $nb_due_date, $third_party, $item_props, $fee_ack) = @_;
562 $self->verify_session;
564 my $trans = OpenILS::SIP::Transaction::Renew->new( authtoken => $self->{authtoken} );
565 $trans->patron($self->find_patron($patron_id));
566 $trans->item($self->find_item($item_id));
568 if(!$trans->patron) {
569 $trans->screen_msg("Invalid patron barcode.");
574 if(!$trans->patron->renew_ok) {
575 $trans->screen_msg("Renewals not allowed.");
582 $trans->screen_msg("Item Id renewal not supported.");
584 $trans->screen_msg("Invalid item barcode.");
590 if(!$trans->item->{patron} or
591 $trans->item->{patron} ne $patron_id) {
592 $trans->screen_msg("Item not checked out to " . $trans->patron->name);
597 # Perform the renewal
600 $trans->desensitize(0); # It's already checked out
601 $trans->item->{due_date} = $nb_due_date if $no_block eq 'Y';
602 $trans->item->{sip_item_properties} = $item_props if $item_props;
613 # my ($self, $patron_id, $patron_pwd, $fee_ack) = @_;
614 # my ($patron, $item_id);
617 # $trans = new ILS::Transaction::RenewAll;
619 # $trans->patron($patron = new ILS::Patron $patron_id);
620 # if (defined $patron) {
621 # syslog("LOG_DEBUG", "ILS::renew_all: patron '%s': renew_ok: %s",
622 # $patron->name, $patron->renew_ok);
624 # syslog("LOG_DEBUG", "ILS::renew_all: Invalid patron id: '%s'",
628 # if (!defined($patron)) {
629 # $trans->screen_msg("Invalid patron barcode.");
631 # } elsif (!$patron->renew_ok) {
632 # $trans->screen_msg("Renewals not allowed.");
634 # } elsif (defined($patron_pwd) && !$patron->check_password($patron_pwd)) {
635 # $trans->screen_msg("Invalid patron password.");
639 # foreach $item_id (@{$patron->{items}}) {
640 # my $item = new ILS::Item $item_id;
642 # if (!defined($item)) {
643 # syslog("LOG_WARNING",
644 # "renew_all: Invalid item id associated with patron '%s'",
649 # if (@{$item->hold_queue}) {
650 # # Can't renew if there are outstanding holds
651 # push @{$trans->unrenewed}, $item_id;
653 # $item->{due_date} = time + (14*24*60*60); # two weeks hence
654 # push @{$trans->renewed}, $item_id;