Add CW MARS Perl Customization
authorJason Stephenson <jason@sigio.com>
Tue, 23 May 2023 17:28:05 +0000 (13:28 -0400)
committerJason Stephenson <jason@sigio.com>
Tue, 23 May 2023 17:28:05 +0000 (13:28 -0400)
Open-ILS/src/perlmods/lib/OpenILS/Application/AppUtils.pm
Open-ILS/src/perlmods/lib/OpenILS/Application/Search/Biblio.pm
Open-ILS/src/perlmods/lib/OpenILS/Const.pm
Open-ILS/src/perlmods/lib/OpenILS/SIP/Patron.pm
Open-ILS/src/perlmods/lib/OpenILS/WWW/EGCatLoader.pm
Open-ILS/src/perlmods/lib/OpenILS/WWW/EGCatLoader/Ecard.pm [new file with mode: 0644]
Open-ILS/src/perlmods/lib/OpenILS/WWW/EGCatLoader/Register.pm
Open-ILS/src/perlmods/lib/OpenILS/WWW/SuperCat.pm

index 59a11f6..81118d3 100644 (file)
@@ -2518,6 +2518,79 @@ sub verify_migrated_user_password {
         $e, $user_id, md5_hex($salt . $md5_pass), $pw_type);
 }
 
+# Calculate a barcode check digit using the Luhn algorithm:
+# https://en.wikipedia.org/wiki/Luhn_algorithm
+# Takes a string of digits and returns the checkdigit.
+# -1 is returned if the string contains any characters other than digits.
+sub calculate_luhn_checkdigit {
+    my ($class, $input) = @_;
+    return -1 unless ($input =~ /^\d+$/);
+    my @bc = reverse(split(//, $input));
+    my $mult = 2;
+    my $sum = 0;
+    for (my $i = 0; $i < @bc; $i++) {
+        my $v = $bc[$i] * $mult;
+        $v -= 9 if ($v > 9);
+        $sum += $v;
+        $mult = ($mult == 2) ? 1 : 2;
+    }
+    return ($sum % 10) ? 10 - ($sum % 10) : 0;
+}
+
+# Generate a barcode using a combination of:
+# $prefix : A prefix sequence for the barcode.
+# $length : The total lenght for the generated barcode, including
+#           length of the prefix and checkdigit (if any).
+# $checkdigit: A boolean, whether or not to calculate a check digit.
+# $sequence: A database sequence to use as a source of the main digit
+#            sequence for the barcode.
+# $e : An optional CStoreEditor to use for queries.  If not provided,
+#      a new one will be created and used.
+#
+# Returns the new barcode or undef on failure.
+sub generate_barcode {
+    my ($class, $prefix, $length, $checkdigit, $sequence, $e) = @_;
+    $e = OpenILS::Utils::CStoreEditor->new() unless($e);
+    # Don't do checkdigit if prefix is not all numbers.
+    if ($prefix !~ /^\d+$/) {
+        $checkdigit = 0;
+    }
+    $length = $length - length($prefix);
+    $length -= 1 if ($checkdigit);
+    if ($length > 0) {
+        my $barcode;
+        do {
+            my $r = $e->json_query(
+                {from => [
+                    'actor.generate_barcode',
+                    $prefix,
+                    $length,
+                    $sequence
+                ]});
+            if ($r && $r->[0] && $r->[0]->{'actor.generate_barcode'}) {
+                $barcode = $r->[0]->{'actor.generate_barcode'};
+                if ($checkdigit) {
+                    $barcode .= $class->calculate_luhn_checkdigit($barcode);
+                }
+                # Check for duplication.
+                my $x = $e->json_query(
+                    {
+                        select => ['id'],
+                        from => 'ac',
+                        where => {
+                            barcode => $barcode
+                        }
+                    }
+                );
+                undef($barcode) if ($x && $x->[0]);
+            } else {
+                return undef;
+            }
+        } until ($barcode);
+        return $barcode;
+    }
+    return undef;
+}
 
 # generate a MARC XML document from a MARC XML string
 sub marc_xml_to_doc {
index 8ea3324..cf1834c 100644 (file)
@@ -3070,8 +3070,15 @@ __PACKAGE__->register_method(
             desc => q/
                 Stream of record summary objects including id, record,
                 hold_count, copy_counts, display (metabib display
-                fields), attributes (metabib record attrs), plus
-                metabib_id and metabib_records for the metabib variant.
+                fields), and attributes (metabib record attrs).  The
+                metabib variant of the call gets metabib_id and
+                metabib_records, and the regular record version also
+                gets some metabib information, but returns them as
+                staff_view_metabib_id, staff_view_metabib_records, and
+                staff_view_metabib_attributes.  This is to mitigate the
+                need for code changes elsewhere where assumptions are
+                made when certain fields are returned.
+                
             /
         }
     }
@@ -3133,6 +3140,46 @@ sub catalog_record_summary {
             get_one_metarecord_summary($self, $e, $org_id, $rec_id) :
             get_one_record_summary($self, $e, $org_id, $rec_id);
 
+        # Let's get Formats & Editions data FIXME: consider peer bibs?
+        unless ($is_meta) {
+            my $meta_search = $e->search_metabib_metarecord_source_map({source => $rec_id});
+            if ($meta_search) {
+                $response->{staff_view_metabib_id} = $meta_search->[0]->metarecord;
+                my $maps = $e->search_metabib_metarecord_source_map({metarecord => $response->{staff_view_metabib_id}});
+                my @metabib_records = map { $_->source } @$maps;
+                $response->{staff_view_metabib_records} = \@metabib_records;
+
+                my $attributes = $U->get_bre_attrs(\@metabib_records);
+                # we get "243":{
+                #       "srce":{
+                #         "code":" ",
+                #         "label":"National bibliographic agency"
+                #       }, ...}
+                my $metabib_attr = {};
+
+                foreach my $bib_id ( keys %{ $attributes } ) {
+                    foreach my $ctype ( keys %{ $attributes->{$bib_id} } ) {
+                        # we want {
+                        #   "srce":{ " ": { "label": "National bibliographic agency", "count" : 1 } },
+                        #       ...
+                        #   }
+                        my $current_code = $attributes->{$bib_id}->{$ctype}->{code};
+                        my $code_label = $attributes->{$bib_id}->{$ctype}->{label};
+                        $metabib_attr->{$ctype} = {} unless $metabib_attr->{$ctype};
+                        if (! $metabib_attr->{$ctype}->{ $current_code }) {
+                            $metabib_attr->{$ctype}->{ $current_code } = {
+                                "label" => $code_label,
+                                "count" => 1
+                            }
+                        } else {
+                            $metabib_attr->{$ctype}->{ $current_code }->{count}++;
+                        }
+                    }
+                }
+                $response->{staff_view_metabib_attributes} = $metabib_attr;
+            }
+        }
+
         ($response->{copy_counts}) = $copy_method->run($org_id, $rec_id);
 
         $response->{first_call_number} = get_first_call_number(
index 0ff4880..fccfd14 100644 (file)
@@ -128,8 +128,10 @@ econst OILS_ACQ_DEBIT_TYPE_TRANSFER => 'xfer';
 econst OILS_PENALTY_AUTO_ID => 100;
 econst OILS_PENALTY_PATRON_EXCEEDS_FINES => 1;
 econst OILS_PENALTY_PATRON_EXCEEDS_OVERDUE_COUNT => 2;
+econst OILS_PENALTY_PATRON_EXCEEDS_CHECKOUT_COUNT => 3;
+econst OILS_PENALTY_PATRON_EXCEEDS_LOST_COUNT => 5;
 econst OILS_PENALTY_INVALID_PATRON_ADDRESS => 29;
-
+econst OILS_PENALTY_PATRON_EXCEEDS_LONGOVERDUE_COUNT => 35;
 
 econst OILS_BILLING_TYPE_NOTIFICATION_FEE => 9;
 
index e7ba27a..16e80d7 100644 (file)
@@ -491,15 +491,18 @@ sub print_line {            # not implemented
     return '';
 }
 
-sub too_many_charged {      # not implemented
+sub too_many_charged {
     my $self = shift;
-    return 0;
+    return scalar(
+        grep { $_->id == OILS_PENALTY_PATRON_EXCEEDS_CHECKOUT_COUNT } @{$self->{user}->standing_penalties}
+    );
 }
 
-sub too_many_overdue { 
+sub too_many_overdue {
     my $self = shift;
-    return scalar( # PATRON_EXCEEDS_OVERDUE_COUNT
-        grep { $_->id == OILS_PENALTY_PATRON_EXCEEDS_OVERDUE_COUNT } @{$self->{user}->standing_penalties}
+    return scalar( # PATRON_EXCEEDS_OVERDUE_COUNT || PATRON_EXCEEDS_LONGOVERDUE_COUNT
+        grep { $_->id == OILS_PENALTY_PATRON_EXCEEDS_OVERDUE_COUNT
+           || $_->id == OILS_PENALTY_PATRON_EXCEEDS_LONGOVERDUE_COUNT } @{$self->{user}->standing_penalties}
     );
 }
 
@@ -515,10 +518,11 @@ sub too_many_claim_return {
     return 0;
 }
 
-# not relevant, handled by fines/fees
 sub too_many_lost {
     my $self = shift;
-    return 0;
+    return scalar(
+        grep { $_->id == OILS_PENALTY_PATRON_EXCEEDS_LOST_COUNT } @{$self->{user}->standing_penalties}
+    );
 }
 
 sub excessive_fines { 
index 47f2e50..478dfe7 100644 (file)
@@ -30,6 +30,7 @@ use OpenILS::WWW::EGCatLoader::Container;
 use OpenILS::WWW::EGCatLoader::SMS;
 use OpenILS::WWW::EGCatLoader::Register;
 use OpenILS::WWW::EGCatLoader::OpenAthens;
+use OpenILS::WWW::EGCatLoader::Ecard;
 
 my $U = 'OpenILS::Application::AppUtils';
 
@@ -185,6 +186,10 @@ sub load {
 
     $self->load_simple("myopac") if $path =~ m:opac/myopac:; # A default page for myopac parts
 
+    return $self->load_ecard_form($path) if $path =~ m|opac/ecard/form|;
+    return $self->load_ecard_submit if $path =~ m|opac/ecard/submit|;
+    return $self->load_ecard_verify if $path =~ m|opac/ecard/verify|;
+
     if($path =~ m|opac/login|) {
         return $self->load_login unless $self->editor->requestor; # already logged in?
 
diff --git a/Open-ILS/src/perlmods/lib/OpenILS/WWW/EGCatLoader/Ecard.pm b/Open-ILS/src/perlmods/lib/OpenILS/WWW/EGCatLoader/Ecard.pm
new file mode 100644 (file)
index 0000000..ce8d673
--- /dev/null
@@ -0,0 +1,746 @@
+package OpenILS::WWW::EGCatLoader;
+use strict; use warnings;
+use Apache2::Const -compile => qw(OK FORBIDDEN HTTP_INTERNAL_SERVER_ERROR);
+use OpenSRF::Utils::Logger qw/$logger/;
+use OpenSRF::Utils::JSON;
+use OpenSRF::Utils qw/:datetime/;
+use OpenILS::Utils::Fieldmapper;
+use OpenILS::Application::AppUtils;
+use OpenILS::Utils::CStoreEditor qw/:funcs/;
+use OpenILS::Event;
+use Data::Dumper;
+use LWP::UserAgent;
+use DateTime;
+use Digest::MD5 qw(md5_hex);
+$Data::Dumper::Indent = 0;
+my $U = 'OpenILS::Application::AppUtils';
+
+my @api_fields = (
+    {name => 'vendor_username', required => 1},
+    {name => 'vendor_password', required => 1},
+    {name => 'first_given_name', class => 'au', required => 1},
+    {name => 'second_given_name', class => 'au'},
+    {name => 'family_name', class => 'au', required => 1},
+    {name => 'suffix', class => 'au'},
+    {name => 'email', class => 'au', required => 1},
+    {name => 'passwd', class => 'au', required => 1},
+    {name => 'day_phone', class => 'au', required => 0},
+    {name => 'dob', class => 'au', required => 1},
+    {name => 'home_ou', class => 'au', required => 1},
+    {name => 'ident_type', class => 'au', required => 0},
+    {name => 'ident_value', class => 'au', required => 0},
+    {name => 'guardian',
+     class => 'au', 
+     notes => "AKA parent/guardian",
+     required_if => 'Patron is less than 18 years old'
+    },
+    {name => 'pref_first_given_name', class => 'au'},
+    {name => 'pref_second_given_name', class => 'au'},
+    {name => 'pref_family_name', class => 'au'},
+    {name => 'pref_suffix', class => 'au'},
+    {name => 'physical_street1', class => 'aua', required => 1},
+    {name => 'physical_street1_name'},
+    {name => 'physical_street2', class => 'aua'},
+    {name => 'physical_city', class => 'aua', required => 1},
+    {name => 'physical_post_code', class => 'aua', required => 1},
+    {name => 'physical_county', class => 'aua', required => 1},
+    {name => 'physical_state', class => 'aua', required => 1},
+    {name => 'physical_country', class => 'aua', required => 1},
+    {name => 'mailing_street1', class => 'aua', required => 1},
+    {name => 'mailing_street1_name'},
+    {name => 'mailing_street2', class => 'aua'},
+    {name => 'mailing_city', class => 'aua', required => 1},
+    {name => 'mailing_post_code', class => 'aua', required => 1},
+    {name => 'mailing_county', class => 'aua', required => 1},
+    {name => 'mailing_state', class => 'aua', required => 1},
+    {name => 'mailing_country', class => 'aua', required => 1},
+    {name => 'voter_registration', class => 'asvr', required => 0},
+    {name => 'in_house_registration', required => 0},
+    {name => 'newsletter', required => 0},
+);
+
+
+sub load_ecard_form {
+    my $self = shift;
+    my $path = shift; # Give us the path to determine the language
+    my $ctx = $self->ctx;
+    my $cgi = $self->cgi;
+
+    my $ctx_org = $ctx->{physical_loc} || $self->_get_search_lib();
+    $ctx->{ecard} = {};
+    $ctx->{ecard}->{enabled} = $U->is_true($U->ou_ancestor_setting_value(
+        $ctx_org, 'opac.ecard_registration_enabled'
+    ));
+    $ctx->{ecard}->{quipu_id} = $U->ou_ancestor_setting_value(
+        $ctx_org, 'lib.ecard_quipu_id'
+    ) || 0;
+
+    # Determine the language code from the path
+    $ctx->{ecard}->{lang} = 'en'; # English is default
+    if ($path =~ m|opac/ecard/form_([a-z]{2})|) {
+        $ctx->{ecard}->{lang} = $1;
+    }
+
+    return Apache2::Const::OK;
+}
+
+# TODO: wrap the following in a check for a library setting as to whether or not
+# to require emailed verification
+
+## Random 6-character alpha-numeric code that avoids look-alike characters
+## https://ux.stackexchange.com/questions/53341/are-there-any-letters-numbers-that-should-be-avoided-in-an-id
+## Also exclude vowels to avoid creating any real (potentially offensive) words.
+#my @code_chars = ('C','D','F','H','J'..'N','P','R','T','V','W','X','3','4','7','9');
+#sub generate_verify_code {
+#    my $string = '';
+#    $string .= $code_chars[rand @code_chars] for 1..6;
+#    return $string;
+#}
+#
+#
+## only if we're verifying the card via email
+#sub load_ecard_verify {
+#    my $self = shift;
+#    my $cgi = $self->cgi;
+#    $self->collect_header_footer;
+#
+#    # Loading the form.
+#    return Apache2::Const::OK if $cgi->request_method eq 'GET';
+#
+#    #$self->verify_ecard;
+#    return Apache2::Const::OK;
+#}
+#
+#sub verify_ecard {
+#    my $self = shift;
+#    my $cgi = $self->cgi;
+#    my $ctx = $self->ctx;
+#    $self->log_params;
+#
+#    my $verify_code = $ctx->{verify_code} = $cgi->param('verification_code');
+#    my $barcode = $ctx->{barcode} = $cgi->param('barcode');
+#
+#    $ctx->{verify_failed} = 1;
+#
+#    my $e = new_editor();
+#
+#    my $au = $e->search_actor_user({
+#        profile => $PROVISIONAL_ECARD_GRP,
+#        ident_type => $ECARD_VERIFY_IDENT,
+#        ident_value => $verify_code
+#    })->[0];
+#
+#    if (!$au) {
+#        $logger->warn(
+#            "ECARD: No provisional ecard found with code $verify_code");
+#        sleep 2; # Mitigate brute-force attacks
+#        return;
+#    }
+#
+#    my $card = $e->search_actor_card({
+#        usr => $au->id,
+#        barcode => $barcode
+#    })->[0];
+#
+#    if (!$card) {
+#        $logger->warn("ECARD: Failed to match verify code ".
+#            "($verify_code) with provided barcode ($barcode)");
+#        sleep 2; # Mitigate brute-force attacks
+#        return;
+#    }
+#
+#    # Verification looks good.  Update the account.
+#
+#    my $grp = new_editor()->retrieve_permission_grp_tree($FULL_ECARD_GRP);
+#
+#    $au->profile($grp->id);
+#    $au->expire_date(
+#        DateTime->now(time_zone => 'local')->add(
+#            seconds => interval_to_seconds($grp->perm_interval))->iso8601()
+#    );
+#
+#    $e->xact_begin;
+#
+#    unless ($e->update_actor_user($au)) {
+#        $logger->error("ECARD update failed for $barcode: " . $e->die_event);
+#        return;
+#    }
+#    
+#    $e->commit;
+#    $logger->info("ECARD: Update to full ecard succeeded for $barcode");
+#
+#    $ctx->{verify_success} = 1;
+#    $ctx->{verify_failed} = 0;
+#
+#    return;
+#}
+
+
+sub log_params {
+    my $self = shift;
+    my $cgi = $self->cgi;
+    my @params = $cgi->param;
+
+    my $msg = '';
+    for my $p (@params) {
+        next if $p =~ /pass/;
+        $msg .= "|" if $msg; 
+        $msg .= "$p=".$cgi->param($p);
+    }
+
+    $logger->info("ECARD: Submit params: $msg");
+}
+
+sub handle_testmode_api {
+    my $self = shift;
+    my $ctx = $self->ctx;
+
+    # Strip data we don't want to publish.
+    my @doc_fields;
+    for my $field_info (@api_fields) {
+        my $doc_info = {};
+        for my $info_key (keys %$field_info) {
+            $doc_info->{$info_key} = $field_info->{$info_key} 
+                unless $info_key eq 'class';
+        }
+        push(@doc_fields, $doc_info);
+    }
+
+    $ctx->{response}->{messages} = [fields => \@doc_fields];
+    $ctx->{response}->{status} = 'API_OK';
+    return $self->compile_response;
+}
+
+sub handle_datamode_api {
+    my $self = shift;
+    my $datamode = shift;
+    my $ctx = $self->ctx;
+
+    if ($datamode =~ /org_units/) {
+        my $orgs = new_editor()->search_actor_org_unit({opac_visible => 't'});
+        my $list = [
+            map { 
+                {name => $_->name, id => $_->id, parent_ou => $_->parent_ou} 
+            } @$orgs
+        ];
+        $ctx->{response}->{messages} = [org_units => $list];
+    }
+
+    $ctx->{response}->{status} = 'DATA_OK';
+    return $self->compile_response;
+}
+
+sub load_ecard_submit {
+    my $self = shift;
+    my $ctx = $self->ctx;
+    my $cgi = $self->cgi;
+
+    $self->log_params;
+
+    my $testmode = $cgi->param('testmode') || '';
+    my $datamode = $cgi->param('datamode') || '';
+
+    my $e = $ctx->{editor} = new_editor();
+    $ctx->{response} = {messages => []};
+
+    if ($testmode eq 'CONNECT') {
+        $ctx->{response}->{status} = 'CONNECT_OK';
+        return $self->compile_response;
+    }
+
+    return Apache2::Const::FORBIDDEN unless 
+        $cgi->request_method eq 'POST' &&
+        $self->verify_vendor_host &&
+        $self->login_vendor;
+
+    if ($testmode eq 'AUTH') {
+        # If we got this far, the caller is authorized.
+        $ctx->{response}->{status} = 'AUTH_OK';
+        return $self->compile_response;
+    }
+
+    return $self->handle_testmode_api if $testmode eq 'API';
+    return $self->handle_datamode_api($datamode) if $datamode;
+
+    return $self->compile_response unless $self->make_user;
+    return $self->compile_response unless $self->add_addresses;
+    return $self->compile_response unless $self->add_stat_cats;
+    return $self->compile_response unless $self->check_dupes;
+    return $self->compile_response unless $self->add_card;
+    # Add survey responses commented out because it is not universal.
+    # We should come up with a way to configure it before uncommenting
+    # it globally.
+    #return $self->compile_response unless $self->add_survey_responses;
+    return $self->compile_response unless $self->save_user;
+    return $self->compile_response unless $self->add_usr_settings;
+    return $self->compile_response if $ctx->{response}->{status};
+
+    # The code below does nothing in a stock Evergreen installation.
+    # It is included in case a site wishes to set up action trigger
+    # events to do some additional verification or notification for
+    # patrons who have signed up for an eCard.
+    $U->create_events_for_hook(
+        'au.create.ecard', $ctx->{user}, $ctx->{user}->home_ou);
+
+    $ctx->{response}->{status} = 'OK';
+    $ctx->{response}->{barcode} = $ctx->{user}->card->barcode;
+    $ctx->{response}->{expiration_date} = substr($ctx->{user}->expire_date, 0, 10);
+
+    return $self->compile_response;
+}
+
+# E-card vendor is not a regular account.  They must have an entry in 
+# the password table with password type ecard_vendor.
+sub login_vendor {
+    my $self = shift;
+    my $username = $self->cgi->param('vendor_username');
+    my $password = $self->cgi->param('vendor_password');
+    my $home_ou = $self->cgi->param('home_ou');
+
+    my $e = new_editor();
+    my $vendor = $e->search_actor_user({usrname => $username})->[0];
+    return 0 unless $vendor;
+
+    return unless $U->verify_user_password(
+        $e, $vendor->id, $password, 'ecard_vendor');
+
+    # Auth checks out OK.  Manually create an authtoken
+    my %admin_settings = $U->ou_ancestor_setting_batch_insecure(
+        $home_ou,
+        [
+            'lib.ecard_admin_usrname',
+            'lib.ecard_admin_org_unit'
+        ]
+    );
+    my $admin_usr = $e->search_actor_user({usrname => $admin_settings{'lib.ecard_admin_usrname'}->{'value'}})->[0]
+        || $vendor;
+    my $admin_org = $admin_settings{'lib.ecard_admin_org_unit'}->{'value'} || 1;
+    my $auth = $U->simplereq(
+        'open-ils.auth_internal',
+        'open-ils.auth_internal.session.create',
+        {user_id => $admin_usr->id(), org_unit => $admin_org, login_type => 'temp'}
+    );
+
+    return unless $auth && $auth->{textcode} eq 'SUCCESS';
+
+    $self->ctx->{authtoken} = $auth->{payload}->{authtoken};
+
+    return 1;
+}
+
+sub verify_vendor_host {
+    my $self = shift;
+    # TODO
+    # Confirm calling host matches AOUS ecard.vendor.host
+    # NOTE: we may not have that information inside the firewall.
+    return 1;
+}
+
+
+sub compile_response {
+    my $self = shift;
+    my $ctx = $self->ctx;
+    $self->apache->content_type("application/json; charset=utf-8");
+    $ctx->{response} = OpenSRF::Utils::JSON->perl2JSON($ctx->{response});
+    $logger->info("ECARD responding with " . $ctx->{response});
+    return Apache2::Const::OK;
+}
+
+my %keep_case = (usrname => 1, passwd => 1, email => 1);
+sub upperclense {
+    my $self = shift;
+    my $field = shift;
+    my $value = shift;
+    $value = uc($value) unless $keep_case{$field};
+    $value = lc($value) if $field eq 'email'; # force it
+    $value =~ s/(^\s*|\s*$)//g;
+    return $value;
+}
+
+# Create actor.usr perl object and populate column data
+sub make_user {
+    my $self = shift;
+    my $ctx = $self->ctx;
+    my $cgi = $self->cgi;
+
+    my $au = Fieldmapper::actor::user->new;
+
+    $au->isnew(1);
+    $au->net_access_level(1); # Filtered
+    my $home_ou = $cgi->param('home_ou');
+
+    my $perm_grp = $U->ou_ancestor_setting_value(
+        $home_ou,
+        'lib.ecard_patron_profile'
+    );
+
+    $au->profile($perm_grp);
+    my $grp = new_editor()->retrieve_permission_grp_tree($perm_grp);
+
+    $au->expire_date(
+        DateTime->now(time_zone => 'local')->add(
+            seconds => interval_to_seconds($grp->perm_interval))->iso8601()
+    );
+
+    for my $field_info (@api_fields) {
+        my $field = $field_info->{name};
+        next unless $field_info->{class} eq 'au';
+
+        my $val = $cgi->param($field);
+
+        $au->juvenile(1) if $field eq 'guardian' && $val;
+        $au->day_phone(undef) if $field eq 'day_phone' && $val eq '--';
+
+        if ($field_info->{required} && !$val) {
+            my $msg = "Value required for field: '$field'";
+            $ctx->{response}->{status} = 'INVALID_PARAMS';
+            push(@{$ctx->{response}->{messages}}, $msg);
+            $logger->error("ECARD $msg");
+        }
+
+        $self->verify_dob($val) if $field eq 'dob' && $val;
+        $au->$field($val);
+    }
+
+    # CW MARS: Force ident_type to 1.
+    $au->ident_type(1);
+
+    return undef if $ctx->{response}->{status}; 
+    return $ctx->{user} = $au;
+}
+
+sub add_card {
+    my $self = shift;
+    my $ctx = $self->ctx;
+    my $cgi = $self->cgi;
+    my $user = $ctx->{user};
+    my $home_ou = $cgi->param('home_ou');
+
+    my %settings = $U->ou_ancestor_setting_batch_insecure(
+        $home_ou,
+        [
+            'lib.ecard_barcode_prefix',
+            'lib.ecard_barcode_length',
+            'lib.ecard_barcode_calculate_checkdigit'
+        ]
+    );
+    my $prefix = $settings{'lib.ecard_barcode_prefix'}->{'value'}
+        || 'AUTO';
+    my $length = $settings{'lib.card_barcode_length'}->{'value'}
+        || 14;
+    my $cd = $settings{'lib.ecard_barcode_calculate_checkdigit'}->{'value'}
+        || 0;
+
+    my $barcode = $U->generate_barcode(
+        $prefix,
+        $length,
+        $U->is_true($cd),
+        'actor.auto_barcode_ecard_seq'
+    );
+
+    $logger->info("ECARD using generated barcode: $barcode");
+
+    my $card = Fieldmapper::actor::card->new;
+    $card->id(-1);
+    $card->isnew(1);
+    $card->usr($user->id);
+    $card->barcode($barcode);
+
+    # username defaults to barcode
+    $user->usrname($barcode);
+    $user->card($card);
+    $user->cards([$card]);
+
+    return 1;
+}
+
+# Returns 1 on success, undef on error.
+sub verify_dob {
+    my $self = shift;
+    my $dob = shift;
+    my $ctx = $self->ctx;
+    my $cgi = $self->cgi;
+
+    my @parts = split(/-/, $dob);
+    my $dob_date;
+
+    eval { # avoid dying on funky dates
+        $dob_date = DateTime->new(
+            year => $parts[0], month => $parts[1], day => $parts[2]);
+    };
+
+    if (!$dob_date || $dob_date > DateTime->now) {
+        my $msg = "Invalid dob: '$dob'";
+        $ctx->{response}->{status} = 'INVALID_PARAMS';
+        push(@{$ctx->{response}->{messages}}, $msg);
+        $logger->error("ECARD $msg");
+        return undef;
+    }
+
+    # Check if guardian required for underage patrons.
+    # TODO: Add our own setting for this.
+    my $guardian_required = $U->ou_ancestor_setting_value(
+        $cgi->param('home_ou'),
+        'ui.patron.edit.guardian_required_for_juv'
+    );
+
+    my $comp_date = DateTime->now;
+    $comp_date->set_hour(0);
+    $comp_date->set_minute(0);
+    $comp_date->set_second(0);
+    # The juvenile age should be configurable.
+    $comp_date->subtract(years => 18); # juv age
+
+    if ($U->is_true($guardian_required)
+        && $dob_date > $comp_date
+        && !$cgi->param('guardian')) {
+
+        my $msg = "Parent/Guardian (guardian) is required for patrons ".
+            "under 18 years of age. dob=$dob";
+        $ctx->{response}->{status} = 'INVALID_PARAMS';
+        push(@{$ctx->{response}->{messages}}, $msg);
+        $logger->error("ECARD $msg");
+        return undef;
+    }
+
+    return 1;
+}
+
+# returns true if the addresses contain all of the same values.
+sub addrs_match {
+    my ($self, $addr1, $addr2) = @_;
+    for my $field ($addr1->real_fields) {
+        return 0 if ($addr1->$field() || '') ne ($addr2->$field() || '');
+    }
+    return 1;
+}
+
+
+sub add_addresses {
+    my $self = shift;
+    my $cgi = $self->cgi;
+    my $ctx = $self->ctx;
+    my $e = $ctx->{editor};
+    my $user = $ctx->{user};
+
+    my $physical_addr = Fieldmapper::actor::user_address->new;
+    $physical_addr->isnew(1);
+    $physical_addr->usr($user->id);
+    $physical_addr->address_type('PHYSICAL');
+    $physical_addr->within_city_limits('f');
+
+    my $mailing_addr = Fieldmapper::actor::user_address->new;
+    $mailing_addr->isnew(1);
+    $mailing_addr->usr($user->id);
+    $mailing_addr->address_type('MAILING');
+    $mailing_addr->within_city_limits('f');
+
+   # Use as both billing and mailing via virtual ID.
+    $physical_addr->id(-1);
+    $mailing_addr->id(-2);
+    $user->billing_address(-1);
+    $user->mailing_address(-2);
+
+    # Confirm we have values for all of the required fields.
+    # Apply values to our in-progress address object.
+    for my $field_info (@api_fields) {
+        my $field = $field_info->{name};
+        next unless $field =~ /physical|mailing/;
+        next if $field =~ /street1_/;
+
+        my $val = $cgi->param($field);
+
+        if ($field_info->{required} && !$val) {
+            my $msg = "Value required for field: '$field'";
+            $ctx->{response}->{status} = 'INVALID_PARAMS';
+            push(@{$ctx->{response}->{messages}}, $msg);
+            $logger->error("ECARD $msg");
+        }
+
+        if ($field =~ /physical/) {
+            (my $col_field = $field) =~ s/physical_//g;
+            $physical_addr->$col_field($val);
+        } else {
+            (my $col_field = $field) =~ s/mailing_//g;
+            $mailing_addr->$col_field($val);
+        }
+
+    }
+
+    # exit if there were any errors above.
+    return undef if $ctx->{response}->{status}; 
+
+    $user->billing_address($physical_addr);
+    $user->mailing_address($mailing_addr);
+    $user->addresses([$physical_addr, $mailing_addr]);
+
+    return 1;
+}
+
+# TODO: The code in add_usr_settings is totally arbitrary and should
+# be modified to look up settings in the database.
+sub add_usr_settings {
+    my $self = shift;
+    my $cgi = $self->cgi;
+    my $ctx = $self->ctx;
+    my $user = $ctx->{user};
+    my %settings = (
+        'opac.hold_notify' => 'email'
+    );
+
+    $U->simplereq(
+        'open-ils.actor',
+        'open-ils.actor.patron.settings.update',
+        $self->ctx->{authtoken}, $user->id, \%settings);
+
+    return 1;
+}
+
+# TODO: This implementation of add_survey_responses is PINES-specific.
+# KCLS does something else.  The line that calls this subroutine is
+# commented out above.  This should be modified to look up settings in
+# the database.
+sub add_survey_responses {
+    my $self = shift;
+    my $cgi = $self->cgi;
+    my $user = $self->ctx->{user};
+    my $answer = $cgi->param('voter_registration');
+
+    my $survey_response = Fieldmapper::action::survey_response->new;
+    $survey_response->id(-1);
+    $survey_response->isnew(1);
+    $survey_response->survey(1); # voter registration survey
+    $survey_response->question(1);
+    $survey_response->answer($answer);
+
+    $user->survey_responses([$survey_response]);
+    return 1;
+}
+
+# TODO: this is CW MARS-specific, but maybe we can make it something
+# generic for adding stat cats to the patron
+
+sub add_stat_cats {
+   my $self = shift;
+   my $cgi = $self->cgi;
+   my $user = $self->ctx->{user};
+
+   my $newsletter = $cgi->param('newsletter');
+   my $map = Fieldmapper::actor::stat_cat_entry_user_map->new;
+   $map->isnew(1);
+   $map->stat_cat(28);
+   $map->stat_cat_entry($newsletter ? 'Yes' : 'No');
+
+   $user->stat_cat_entries([$map]);
+   return 1;
+}
+
+# Returns true if no dupes found, false if dupes are found.
+sub check_dupes {
+    my $self = shift;
+    my $ctx  = $self->ctx;
+    my $user = $ctx->{user};
+    my $addr = $user->addresses->[0];
+    my $e = new_editor();
+
+    #TODO: This list of fields should be configurable so that code
+    #changes are not required for different sites with different
+    #criteria.
+    my @dupe_patron_fields = 
+        qw/first_given_name family_name dob/;
+
+    my $search = {
+        first_given_name => {value => $user->first_given_name, group => 0},
+        family_name => {value => $user->family_name, group => 0},
+        dob => {value => substr($user->dob, 0, 4), group => 0} # birth year
+    };
+
+    my $root_org = $e->search_actor_org_unit({parent_ou => undef})->[0];
+
+    my $ids = $U->storagereq(
+        "open-ils.storage.actor.user.crazy_search", 
+        $search,
+        1000,           # search limit
+        undef,          # sort
+        1,              # include inactive
+        $root_org->id,  # ws_ou
+        $root_org->id   # search_ou
+    );
+
+    return 1 if @$ids == 0;
+
+    $logger->info("ECARD found potential duplicate patrons: @$ids");
+
+    if (my $streetname = $self->cgi->param('physical_street1_name')) {
+        # We found matching patrons.  Perform a secondary check on the
+        # address street name only.
+
+        $logger->info("ECARD secondary search on street name: $streetname");
+
+        my $addr_ids = $e->search_actor_user_address(
+            {   usr => $ids,
+                street1 => {'~*' => "(^| )$streetname( |\$)"}
+            }, {idlist => 1}
+        );
+
+        if (@$addr_ids) {
+            # we don't really care what patrons match at this point,
+            # only whether a match is found.
+            $ids = [1];
+            $logger->info("ECARD secondary address check match(es) ".
+                "found on address(es) @$addr_ids");
+
+        } else {
+            $ids = [];
+            $logger->info(
+                "ECARD secondary address check found no matches");
+        }
+
+    } else {
+        $ids = [];
+        # unclear if this is a possibility -- err on the side of allowing
+        # the registration.
+        $logger->info("ECARD found possible patron match but skipping ".
+            "secondary street name check -- no street name was provided");
+    }
+
+    return 1 if @$ids == 0;
+
+    $ctx->{response}->{status} = 'DUPLICATE';
+    $ctx->{response}->{messages} = ['first_given_name', 
+        'family_name', 'dob_year', 'billing_street1_name'];
+    return undef;
+}
+
+
+sub save_user {
+    my $self = shift;
+    my $ctx = $self->ctx;
+    my $cgi = $self->cgi;
+    my $user = $ctx->{user};
+
+    my $resp = $U->simplereq(
+        'open-ils.actor',
+        'open-ils.actor.patron.update',
+        $self->ctx->{authtoken}, $user
+    );
+
+    $resp = {textcode => 'UNKNOWN_ERROR'} unless $resp;
+
+    if ($U->is_event($resp)) {
+
+        my $msg = "Error creating user account: " . $resp->{textcode};
+        $logger->error("ECARD: $msg");
+
+        $ctx->{response}->{status} = 'CREATE_ERR';
+        $ctx->{response}->{messages} = [{msg => $msg, pid => $$}];
+
+        return 0;
+    }
+
+    $ctx->{user} = $resp;
+    return 1;
+}
+
+1;
+
index 4949d10..7732c1a 100644 (file)
@@ -38,6 +38,14 @@ sub load_patron_reg {
         my $val = $cgi->param($_);
         $self->inspect_register_value($_, $val);
         s/^stgu\.//g;
+        # Upcase certain fields per CW MARS
+        my @upcase_fields = ('first_given_name', 'second_given_name', 'family_name',
+                             'pref_first_given_name', 'pref_second_given_name',
+                             'pref_family_name');
+        my $f = $_;
+        if (grep {$f eq $_} @upcase_fields) {
+            $val = uc($val);
+        }
         $user->$_($val);
     }
 
@@ -56,7 +64,7 @@ sub load_patron_reg {
         my $val = $cgi->param($_);
         $self->inspect_register_value($_, $val);
         s/^stgma\.//g;
-        $addr->$_($val);
+        $addr->$_(uc($val)); # Uppercase per CW MARS
         $has_addr = 1;
     }
 
index a522803..eb46f8f 100644 (file)
@@ -2188,7 +2188,7 @@ sub sru_search {
                     }
                 }
 
-                $quote_it = 0 if ( $base eq 'all' );
+                $quote_it = 0 if ( $base eq 'all' || ( $base eq '=' && grep {$qualifier eq $_} qw(eg.keyword eg.title eg.author) ) );
                 $term = maybeQuote($term) if $quote_it;
 
             } else {