Bug 23529: (QA follow-up) Fix closing bracket, add label
[koha.git] / Koha / Patron.pm
blob67ab9bf7c9086ba8a2c40da9d3a6cfb8117b7547
1 package Koha::Patron;
3 # Copyright ByWater Solutions 2014
4 # Copyright PTFS Europe 2016
6 # This file is part of Koha.
8 # Koha is free software; you can redistribute it and/or modify it under the
9 # terms of the GNU General Public License as published by the Free Software
10 # Foundation; either version 3 of the License, or (at your option) any later
11 # version.
13 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
14 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
15 # A PARTICULAR PURPOSE. See the GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License along
18 # with Koha; if not, write to the Free Software Foundation, Inc.,
19 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
21 use Modern::Perl;
23 use Carp;
24 use List::MoreUtils qw( any uniq );
25 use JSON qw( to_json );
26 use Text::Unaccent qw( unac_string );
28 use C4::Context;
29 use C4::Log;
30 use Koha::Account;
31 use Koha::AuthUtils;
32 use Koha::Checkouts;
33 use Koha::Club::Enrollments;
34 use Koha::Database;
35 use Koha::DateUtils;
36 use Koha::Exceptions::Password;
37 use Koha::Holds;
38 use Koha::Old::Checkouts;
39 use Koha::Patron::Attributes;
40 use Koha::Patron::Categories;
41 use Koha::Patron::HouseboundProfile;
42 use Koha::Patron::HouseboundRole;
43 use Koha::Patron::Images;
44 use Koha::Patron::Relationships;
45 use Koha::Patrons;
46 use Koha::Subscription::Routinglists;
47 use Koha::Token;
48 use Koha::Virtualshelves;
50 use base qw(Koha::Object);
52 use constant ADMINISTRATIVE_LOCKOUT => -1;
54 our $RESULTSET_PATRON_ID_MAPPING = {
55 Accountline => 'borrowernumber',
56 Aqbasketuser => 'borrowernumber',
57 Aqbudget => 'budget_owner_id',
58 Aqbudgetborrower => 'borrowernumber',
59 ArticleRequest => 'borrowernumber',
60 BorrowerAttribute => 'borrowernumber',
61 BorrowerDebarment => 'borrowernumber',
62 BorrowerFile => 'borrowernumber',
63 BorrowerModification => 'borrowernumber',
64 ClubEnrollment => 'borrowernumber',
65 Issue => 'borrowernumber',
66 ItemsLastBorrower => 'borrowernumber',
67 Linktracker => 'borrowernumber',
68 Message => 'borrowernumber',
69 MessageQueue => 'borrowernumber',
70 OldIssue => 'borrowernumber',
71 OldReserve => 'borrowernumber',
72 Rating => 'borrowernumber',
73 Reserve => 'borrowernumber',
74 Review => 'borrowernumber',
75 SearchHistory => 'userid',
76 Statistic => 'borrowernumber',
77 Suggestion => 'suggestedby',
78 TagAll => 'borrowernumber',
79 Virtualshelfcontent => 'borrowernumber',
80 Virtualshelfshare => 'borrowernumber',
81 Virtualshelve => 'owner',
84 =head1 NAME
86 Koha::Patron - Koha Patron Object class
88 =head1 API
90 =head2 Class Methods
92 =head3 new
94 =cut
96 sub new {
97 my ( $class, $params ) = @_;
99 return $class->SUPER::new($params);
102 =head3 fixup_cardnumber
104 Autogenerate next cardnumber from highest value found in database
106 =cut
108 sub fixup_cardnumber {
109 my ( $self ) = @_;
110 my $max = Koha::Patrons->search({
111 cardnumber => {-regexp => '^-?[0-9]+$'}
112 }, {
113 select => \'CAST(cardnumber AS SIGNED)',
114 as => ['cast_cardnumber']
115 })->_resultset->get_column('cast_cardnumber')->max;
116 $self->cardnumber(($max || 0) +1);
119 =head3 trim_whitespace
121 trim whitespace from data which has some non-whitespace in it.
122 Could be moved to Koha::Object if need to be reused
124 =cut
126 sub trim_whitespaces {
127 my( $self ) = @_;
129 my $schema = Koha::Database->new->schema;
130 my @columns = $schema->source($self->_type)->columns;
132 for my $column( @columns ) {
133 my $value = $self->$column;
134 if ( defined $value ) {
135 $value =~ s/^\s*|\s*$//g;
136 $self->$column($value);
139 return $self;
142 =head3 plain_text_password
144 $patron->plain_text_password( $password );
146 stores a copy of the unencrypted password in the object
147 for use in code before encrypting for db
149 =cut
151 sub plain_text_password {
152 my ( $self, $password ) = @_;
153 if ( $password ) {
154 $self->{_plain_text_password} = $password;
155 return $self;
157 return $self->{_plain_text_password}
158 if $self->{_plain_text_password};
160 return;
163 =head3 store
165 Patron specific store method to cleanup record
166 and do other necessary things before saving
167 to db
169 =cut
171 sub store {
172 my ($self) = @_;
174 $self->_result->result_source->schema->txn_do(
175 sub {
176 if (
177 C4::Context->preference("autoMemberNum")
178 and ( not defined $self->cardnumber
179 or $self->cardnumber eq '' )
182 # Warning: The caller is responsible for locking the members table in write
183 # mode, to avoid database corruption.
184 # We are in a transaction but the table is not locked
185 $self->fixup_cardnumber;
188 unless( $self->category->in_storage ) {
189 Koha::Exceptions::Object::FKConstraint->throw(
190 broken_fk => 'categorycode',
191 value => $self->categorycode,
195 $self->trim_whitespaces;
197 # Set surname to uppercase if uppercasesurname is true
198 $self->surname( uc($self->surname) )
199 if C4::Context->preference("uppercasesurnames");
201 unless ( $self->in_storage ) { #AddMember
203 # Generate a valid userid/login if needed
204 $self->generate_userid
205 if not $self->userid or not $self->has_valid_userid;
207 # Add expiration date if it isn't already there
208 unless ( $self->dateexpiry ) {
209 $self->dateexpiry( $self->category->get_expiry_date );
212 # Add enrollment date if it isn't already there
213 unless ( $self->dateenrolled ) {
214 $self->dateenrolled(dt_from_string);
217 # Set the privacy depending on the patron's category
218 my $default_privacy = $self->category->default_privacy || q{};
219 $default_privacy =
220 $default_privacy eq 'default' ? 1
221 : $default_privacy eq 'never' ? 2
222 : $default_privacy eq 'forever' ? 0
223 : undef;
224 $self->privacy($default_privacy);
227 # Make a copy of the plain text password for later use
228 $self->plain_text_password( $self->password );
230 # Create a disabled account if no password provided
231 $self->password( $self->password
232 ? Koha::AuthUtils::hash_password( $self->password )
233 : '!' );
235 $self->borrowernumber(undef);
237 $self = $self->SUPER::store;
239 $self->add_enrolment_fee_if_needed(0);
241 logaction( "MEMBERS", "CREATE", $self->borrowernumber, "" )
242 if C4::Context->preference("BorrowersLog");
244 else { #ModMember
246 my $self_from_storage = $self->get_from_storage;
247 # FIXME We should not deal with that here, callers have to do this job
248 # Moved from ModMember to prevent regressions
249 unless ( $self->userid ) {
250 my $stored_userid = $self_from_storage->userid;
251 $self->userid($stored_userid);
254 # Password must be updated using $self->set_password
255 $self->password($self_from_storage->password);
257 if ( C4::Context->preference('FeeOnChangePatronCategory')
258 and $self->category->categorycode ne
259 $self_from_storage->category->categorycode )
261 $self->add_enrolment_fee_if_needed(1);
264 # Actionlogs
265 if ( C4::Context->preference("BorrowersLog") ) {
266 my $info;
267 my $from_storage = $self_from_storage->unblessed;
268 my $from_object = $self->unblessed;
269 my @skip_fields = (qw/lastseen updated_on/);
270 for my $key ( keys %{$from_storage} ) {
271 next if any { /$key/ } @skip_fields;
272 if (
274 !defined( $from_storage->{$key} )
275 && defined( $from_object->{$key} )
277 || ( defined( $from_storage->{$key} )
278 && !defined( $from_object->{$key} ) )
279 || (
280 defined( $from_storage->{$key} )
281 && defined( $from_object->{$key} )
282 && ( $from_storage->{$key} ne
283 $from_object->{$key} )
287 $info->{$key} = {
288 before => $from_storage->{$key},
289 after => $from_object->{$key}
294 if ( defined($info) ) {
295 logaction(
296 "MEMBERS",
297 "MODIFY",
298 $self->borrowernumber,
299 to_json(
300 $info,
301 { utf8 => 1, pretty => 1, canonical => 1 }
307 # Final store
308 $self = $self->SUPER::store;
312 return $self;
315 =head3 delete
317 $patron->delete
319 Delete patron's holds, lists and finally the patron.
321 Lists owned by the borrower are deleted, but entries from the borrower to
322 other lists are kept.
324 =cut
326 sub delete {
327 my ($self) = @_;
329 my $deleted;
330 $self->_result->result_source->schema->txn_do(
331 sub {
332 # Cancel Patron's holds
333 my $holds = $self->holds;
334 while( my $hold = $holds->next ){
335 $hold->cancel;
338 # Delete all lists and all shares of this borrower
339 # Consistent with the approach Koha uses on deleting individual lists
340 # Note that entries in virtualshelfcontents added by this borrower to
341 # lists of others will be handled by a table constraint: the borrower
342 # is set to NULL in those entries.
343 # NOTE:
344 # We could handle the above deletes via a constraint too.
345 # But a new BZ report 11889 has been opened to discuss another approach.
346 # Instead of deleting we could also disown lists (based on a pref).
347 # In that way we could save shared and public lists.
348 # The current table constraints support that idea now.
349 # This pref should then govern the results of other routines/methods such as
350 # Koha::Virtualshelf->new->delete too.
351 # FIXME Could be $patron->get_lists
352 $_->delete for Koha::Virtualshelves->search( { owner => $self->borrowernumber } );
354 $deleted = $self->SUPER::delete;
356 logaction( "MEMBERS", "DELETE", $self->borrowernumber, "" ) if C4::Context->preference("BorrowersLog");
359 return $deleted;
363 =head3 category
365 my $patron_category = $patron->category
367 Return the patron category for this patron
369 =cut
371 sub category {
372 my ( $self ) = @_;
373 return Koha::Patron::Category->_new_from_dbic( $self->_result->categorycode );
376 =head3 image
378 =cut
380 sub image {
381 my ( $self ) = @_;
383 return scalar Koha::Patron::Images->find( $self->borrowernumber );
386 =head3 library
388 Returns a Koha::Library object representing the patron's home library.
390 =cut
392 sub library {
393 my ( $self ) = @_;
394 return Koha::Library->_new_from_dbic($self->_result->branchcode);
397 =head3 guarantor_relationships
399 Returns Koha::Patron::Relationships object for this patron's guarantors
401 Returns the set of relationships for the patrons that are guarantors for this patron.
403 This is returned instead of a Koha::Patron object because the guarantor
404 may not exist as a patron in Koha. If this is true, the guarantors name
405 exists in the Koha::Patron::Relationship object and will have no guarantor_id.
407 =cut
409 sub guarantor_relationships {
410 my ($self) = @_;
412 return Koha::Patron::Relationships->search( { guarantee_id => $self->id } );
415 =head3 guarantee_relationships
417 Returns Koha::Patron::Relationships object for this patron's guarantors
419 Returns the set of relationships for the patrons that are guarantees for this patron.
421 The method returns Koha::Patron::Relationship objects for the sake
422 of consistency with the guantors method.
423 A guarantee by definition must exist as a patron in Koha.
425 =cut
427 sub guarantee_relationships {
428 my ($self) = @_;
430 return Koha::Patron::Relationships->search(
431 { guarantor_id => $self->id },
433 prefetch => 'guarantee',
434 order_by => { -asc => [ 'guarantee.surname', 'guarantee.firstname' ] },
439 =head3 housebound_profile
441 Returns the HouseboundProfile associated with this patron.
443 =cut
445 sub housebound_profile {
446 my ( $self ) = @_;
447 my $profile = $self->_result->housebound_profile;
448 return Koha::Patron::HouseboundProfile->_new_from_dbic($profile)
449 if ( $profile );
450 return;
453 =head3 housebound_role
455 Returns the HouseboundRole associated with this patron.
457 =cut
459 sub housebound_role {
460 my ( $self ) = @_;
462 my $role = $self->_result->housebound_role;
463 return Koha::Patron::HouseboundRole->_new_from_dbic($role) if ( $role );
464 return;
467 =head3 siblings
469 Returns the siblings of this patron.
471 =cut
473 sub siblings {
474 my ($self) = @_;
476 my @guarantors = $self->guarantor_relationships()->guarantors();
478 return unless @guarantors;
480 my @siblings =
481 map { $_->guarantee_relationships()->guarantees() } @guarantors;
483 return unless @siblings;
485 my %seen;
486 @siblings =
487 grep { !$seen{ $_->id }++ && ( $_->id != $self->id ) } @siblings;
489 return wantarray ? @siblings : Koha::Patrons->search( { borrowernumber => { -in => [ map { $_->id } @siblings ] } } );
492 =head3 merge_with
494 my $patron = Koha::Patrons->find($id);
495 $patron->merge_with( \@patron_ids );
497 This subroutine merges a list of patrons into the patron record. This is accomplished by finding
498 all related patron ids for the patrons to be merged in other tables and changing the ids to be that
499 of the keeper patron.
501 =cut
503 sub merge_with {
504 my ( $self, $patron_ids ) = @_;
506 my @patron_ids = @{ $patron_ids };
508 # Ensure the keeper isn't in the list of patrons to merge
509 @patron_ids = grep { $_ ne $self->id } @patron_ids;
511 my $schema = Koha::Database->new()->schema();
513 my $results;
515 $self->_result->result_source->schema->txn_do( sub {
516 foreach my $patron_id (@patron_ids) {
517 my $patron = Koha::Patrons->find( $patron_id );
519 next unless $patron;
521 # Unbless for safety, the patron will end up being deleted
522 $results->{merged}->{$patron_id}->{patron} = $patron->unblessed;
524 while (my ($r, $field) = each(%$RESULTSET_PATRON_ID_MAPPING)) {
525 my $rs = $schema->resultset($r)->search({ $field => $patron_id });
526 $results->{merged}->{ $patron_id }->{updated}->{$r} = $rs->count();
527 $rs->update({ $field => $self->id });
530 $patron->move_to_deleted();
531 $patron->delete();
535 return $results;
540 =head3 wants_check_for_previous_checkout
542 $wants_check = $patron->wants_check_for_previous_checkout;
544 Return 1 if Koha needs to perform PrevIssue checking, else 0.
546 =cut
548 sub wants_check_for_previous_checkout {
549 my ( $self ) = @_;
550 my $syspref = C4::Context->preference("checkPrevCheckout");
552 # Simple cases
553 ## Hard syspref trumps all
554 return 1 if ($syspref eq 'hardyes');
555 return 0 if ($syspref eq 'hardno');
556 ## Now, patron pref trumps all
557 return 1 if ($self->checkprevcheckout eq 'yes');
558 return 0 if ($self->checkprevcheckout eq 'no');
560 # More complex: patron inherits -> determine category preference
561 my $checkPrevCheckoutByCat = $self->category->checkprevcheckout;
562 return 1 if ($checkPrevCheckoutByCat eq 'yes');
563 return 0 if ($checkPrevCheckoutByCat eq 'no');
565 # Finally: category preference is inherit, default to 0
566 if ($syspref eq 'softyes') {
567 return 1;
568 } else {
569 return 0;
573 =head3 do_check_for_previous_checkout
575 $do_check = $patron->do_check_for_previous_checkout($item);
577 Return 1 if the bib associated with $ITEM has previously been checked out to
578 $PATRON, 0 otherwise.
580 =cut
582 sub do_check_for_previous_checkout {
583 my ( $self, $item ) = @_;
585 my @item_nos;
586 my $biblio = Koha::Biblios->find( $item->{biblionumber} );
587 if ( $biblio->is_serial ) {
588 push @item_nos, $item->{itemnumber};
589 } else {
590 # Get all itemnumbers for given bibliographic record.
591 @item_nos = $biblio->items->get_column( 'itemnumber' );
594 # Create (old)issues search criteria
595 my $criteria = {
596 borrowernumber => $self->borrowernumber,
597 itemnumber => \@item_nos,
600 # Check current issues table
601 my $issues = Koha::Checkouts->search($criteria);
602 return 1 if $issues->count; # 0 || N
604 # Check old issues table
605 my $old_issues = Koha::Old::Checkouts->search($criteria);
606 return $old_issues->count; # 0 || N
609 =head3 is_debarred
611 my $debarment_expiration = $patron->is_debarred;
613 Returns the date a patron debarment will expire, or undef if the patron is not
614 debarred
616 =cut
618 sub is_debarred {
619 my ($self) = @_;
621 return unless $self->debarred;
622 return $self->debarred
623 if $self->debarred =~ '^9999'
624 or dt_from_string( $self->debarred ) > dt_from_string;
625 return;
628 =head3 is_expired
630 my $is_expired = $patron->is_expired;
632 Returns 1 if the patron is expired or 0;
634 =cut
636 sub is_expired {
637 my ($self) = @_;
638 return 0 unless $self->dateexpiry;
639 return 0 if $self->dateexpiry =~ '^9999';
640 return 1 if dt_from_string( $self->dateexpiry ) < dt_from_string->truncate( to => 'day' );
641 return 0;
644 =head3 is_going_to_expire
646 my $is_going_to_expire = $patron->is_going_to_expire;
648 Returns 1 if the patron is going to expired, depending on the NotifyBorrowerDeparture pref or 0
650 =cut
652 sub is_going_to_expire {
653 my ($self) = @_;
655 my $delay = C4::Context->preference('NotifyBorrowerDeparture') || 0;
657 return 0 unless $delay;
658 return 0 unless $self->dateexpiry;
659 return 0 if $self->dateexpiry =~ '^9999';
660 return 1 if dt_from_string( $self->dateexpiry, undef, 'floating' )->subtract( days => $delay ) < dt_from_string(undef, undef, 'floating')->truncate( to => 'day' );
661 return 0;
664 =head3 set_password
666 $patron->set_password({ password => $plain_text_password [, skip_validation => 1 ] });
668 Set the patron's password.
670 =head4 Exceptions
672 The passed string is validated against the current password enforcement policy.
673 Validation can be skipped by passing the I<skip_validation> parameter.
675 Exceptions are thrown if the password is not good enough.
677 =over 4
679 =item Koha::Exceptions::Password::TooShort
681 =item Koha::Exceptions::Password::WhitespaceCharacters
683 =item Koha::Exceptions::Password::TooWeak
685 =back
687 =cut
689 sub set_password {
690 my ( $self, $args ) = @_;
692 my $password = $args->{password};
694 unless ( $args->{skip_validation} ) {
695 my ( $is_valid, $error ) = Koha::AuthUtils::is_password_valid( $password );
697 if ( !$is_valid ) {
698 if ( $error eq 'too_short' ) {
699 my $min_length = C4::Context->preference('minPasswordLength');
700 $min_length = 3 if not $min_length or $min_length < 3;
702 my $password_length = length($password);
703 Koha::Exceptions::Password::TooShort->throw(
704 length => $password_length, min_length => $min_length );
706 elsif ( $error eq 'has_whitespaces' ) {
707 Koha::Exceptions::Password::WhitespaceCharacters->throw();
709 elsif ( $error eq 'too_weak' ) {
710 Koha::Exceptions::Password::TooWeak->throw();
715 my $digest = Koha::AuthUtils::hash_password($password);
716 $self->update(
717 { password => $digest,
718 login_attempts => 0,
722 logaction( "MEMBERS", "CHANGE PASS", $self->borrowernumber, "" )
723 if C4::Context->preference("BorrowersLog");
725 return $self;
729 =head3 renew_account
731 my $new_expiry_date = $patron->renew_account
733 Extending the subscription to the expiry date.
735 =cut
737 sub renew_account {
738 my ($self) = @_;
739 my $date;
740 if ( C4::Context->preference('BorrowerRenewalPeriodBase') eq 'combination' ) {
741 $date = ( dt_from_string gt dt_from_string( $self->dateexpiry ) ) ? dt_from_string : dt_from_string( $self->dateexpiry );
742 } else {
743 $date =
744 C4::Context->preference('BorrowerRenewalPeriodBase') eq 'dateexpiry'
745 ? dt_from_string( $self->dateexpiry )
746 : dt_from_string;
748 my $expiry_date = $self->category->get_expiry_date($date);
750 $self->dateexpiry($expiry_date);
751 $self->date_renewed( dt_from_string() );
752 $self->store();
754 $self->add_enrolment_fee_if_needed(1);
756 logaction( "MEMBERS", "RENEW", $self->borrowernumber, "Membership renewed" ) if C4::Context->preference("BorrowersLog");
757 return dt_from_string( $expiry_date )->truncate( to => 'day' );
760 =head3 has_overdues
762 my $has_overdues = $patron->has_overdues;
764 Returns the number of patron's overdues
766 =cut
768 sub has_overdues {
769 my ($self) = @_;
770 my $dtf = Koha::Database->new->schema->storage->datetime_parser;
771 return $self->_result->issues->search({ date_due => { '<' => $dtf->format_datetime( dt_from_string() ) } })->count;
774 =head3 track_login
776 $patron->track_login;
777 $patron->track_login({ force => 1 });
779 Tracks a (successful) login attempt.
780 The preference TrackLastPatronActivity must be enabled. Or you
781 should pass the force parameter.
783 =cut
785 sub track_login {
786 my ( $self, $params ) = @_;
787 return if
788 !$params->{force} &&
789 !C4::Context->preference('TrackLastPatronActivity');
790 $self->lastseen( dt_from_string() )->store;
793 =head3 move_to_deleted
795 my $is_moved = $patron->move_to_deleted;
797 Move a patron to the deletedborrowers table.
798 This can be done before deleting a patron, to make sure the data are not completely deleted.
800 =cut
802 sub move_to_deleted {
803 my ($self) = @_;
804 my $patron_infos = $self->unblessed;
805 delete $patron_infos->{updated_on}; #This ensures the updated_on date in deletedborrowers will be set to the current timestamp
806 return Koha::Database->new->schema->resultset('Deletedborrower')->create($patron_infos);
809 =head3 article_requests
811 my @requests = $borrower->article_requests();
812 my $requests = $borrower->article_requests();
814 Returns either a list of ArticleRequests objects,
815 or an ArtitleRequests object, depending on the
816 calling context.
818 =cut
820 sub article_requests {
821 my ( $self ) = @_;
823 $self->{_article_requests} ||= Koha::ArticleRequests->search({ borrowernumber => $self->borrowernumber() });
825 return $self->{_article_requests};
828 =head3 article_requests_current
830 my @requests = $patron->article_requests_current
832 Returns the article requests associated with this patron that are incomplete
834 =cut
836 sub article_requests_current {
837 my ( $self ) = @_;
839 $self->{_article_requests_current} ||= Koha::ArticleRequests->search(
841 borrowernumber => $self->id(),
842 -or => [
843 { status => Koha::ArticleRequest::Status::Pending },
844 { status => Koha::ArticleRequest::Status::Processing }
849 return $self->{_article_requests_current};
852 =head3 article_requests_finished
854 my @requests = $biblio->article_requests_finished
856 Returns the article requests associated with this patron that are completed
858 =cut
860 sub article_requests_finished {
861 my ( $self, $borrower ) = @_;
863 $self->{_article_requests_finished} ||= Koha::ArticleRequests->search(
865 borrowernumber => $self->id(),
866 -or => [
867 { status => Koha::ArticleRequest::Status::Completed },
868 { status => Koha::ArticleRequest::Status::Canceled }
873 return $self->{_article_requests_finished};
876 =head3 add_enrolment_fee_if_needed
878 my $enrolment_fee = $patron->add_enrolment_fee_if_needed($renewal);
880 Add enrolment fee for a patron if needed.
882 $renewal - boolean denoting whether this is an account renewal or not
884 =cut
886 sub add_enrolment_fee_if_needed {
887 my ($self, $renewal) = @_;
888 my $enrolment_fee = $self->category->enrolmentfee;
889 if ( $enrolment_fee && $enrolment_fee > 0 ) {
890 my $type = $renewal ? 'ACCOUNT_RENEW' : 'ACCOUNT';
891 $self->account->add_debit(
893 amount => $enrolment_fee,
894 user_id => C4::Context->userenv ? C4::Context->userenv->{'number'} : undef,
895 interface => C4::Context->interface,
896 library_id => C4::Context->userenv ? C4::Context->userenv->{'branch'} : undef,
897 type => $type
901 return $enrolment_fee || 0;
904 =head3 checkouts
906 my $checkouts = $patron->checkouts
908 =cut
910 sub checkouts {
911 my ($self) = @_;
912 my $checkouts = $self->_result->issues;
913 return Koha::Checkouts->_new_from_dbic( $checkouts );
916 =head3 pending_checkouts
918 my $pending_checkouts = $patron->pending_checkouts
920 This method will return the same as $self->checkouts, but with a prefetch on
921 items, biblio and biblioitems.
923 It has been introduced to replaced the C4::Members::GetPendingIssues subroutine
925 It should not be used directly, prefer to access fields you need instead of
926 retrieving all these fields in one go.
928 =cut
930 sub pending_checkouts {
931 my( $self ) = @_;
932 my $checkouts = $self->_result->issues->search(
935 order_by => [
936 { -desc => 'me.timestamp' },
937 { -desc => 'issuedate' },
938 { -desc => 'issue_id' }, # Sort by issue_id should be enough
940 prefetch => { item => { biblio => 'biblioitems' } },
943 return Koha::Checkouts->_new_from_dbic( $checkouts );
946 =head3 old_checkouts
948 my $old_checkouts = $patron->old_checkouts
950 =cut
952 sub old_checkouts {
953 my ($self) = @_;
954 my $old_checkouts = $self->_result->old_issues;
955 return Koha::Old::Checkouts->_new_from_dbic( $old_checkouts );
958 =head3 get_overdues
960 my $overdue_items = $patron->get_overdues
962 Return the overdue items
964 =cut
966 sub get_overdues {
967 my ($self) = @_;
968 my $dtf = Koha::Database->new->schema->storage->datetime_parser;
969 return $self->checkouts->search(
971 'me.date_due' => { '<' => $dtf->format_datetime(dt_from_string) },
974 prefetch => { item => { biblio => 'biblioitems' } },
979 =head3 get_routing_lists
981 my @routinglists = $patron->get_routing_lists
983 Returns the routing lists a patron is subscribed to.
985 =cut
987 sub get_routing_lists {
988 my ($self) = @_;
989 my $routing_list_rs = $self->_result->subscriptionroutinglists;
990 return Koha::Subscription::Routinglists->_new_from_dbic($routing_list_rs);
993 =head3 get_age
995 my $age = $patron->get_age
997 Return the age of the patron
999 =cut
1001 sub get_age {
1002 my ($self) = @_;
1003 my $today_str = dt_from_string->strftime("%Y-%m-%d");
1004 return unless $self->dateofbirth;
1005 my $dob_str = dt_from_string( $self->dateofbirth )->strftime("%Y-%m-%d");
1007 my ( $dob_y, $dob_m, $dob_d ) = split /-/, $dob_str;
1008 my ( $today_y, $today_m, $today_d ) = split /-/, $today_str;
1010 my $age = $today_y - $dob_y;
1011 if ( $dob_m . $dob_d > $today_m . $today_d ) {
1012 $age--;
1015 return $age;
1018 =head3 is_valid_age
1020 my $is_valid = $patron->is_valid_age
1022 Return 1 if patron's age is between allowed limits, returns 0 if it's not.
1024 =cut
1026 sub is_valid_age {
1027 my ($self) = @_;
1028 my $age = $self->get_age;
1030 my $patroncategory = $self->category;
1031 my ($low,$high) = ($patroncategory->dateofbirthrequired, $patroncategory->upperagelimit);
1033 return (defined($age) && (($high && ($age > $high)) or ($age < $low))) ? 0 : 1;
1036 =head3 account
1038 my $account = $patron->account
1040 =cut
1042 sub account {
1043 my ($self) = @_;
1044 return Koha::Account->new( { patron_id => $self->borrowernumber } );
1047 =head3 holds
1049 my $holds = $patron->holds
1051 Return all the holds placed by this patron
1053 =cut
1055 sub holds {
1056 my ($self) = @_;
1057 my $holds_rs = $self->_result->reserves->search( {}, { order_by => 'reservedate' } );
1058 return Koha::Holds->_new_from_dbic($holds_rs);
1061 =head3 old_holds
1063 my $old_holds = $patron->old_holds
1065 Return all the historical holds for this patron
1067 =cut
1069 sub old_holds {
1070 my ($self) = @_;
1071 my $old_holds_rs = $self->_result->old_reserves->search( {}, { order_by => 'reservedate' } );
1072 return Koha::Old::Holds->_new_from_dbic($old_holds_rs);
1075 =head3 notice_email_address
1077 my $email = $patron->notice_email_address;
1079 Return the email address of patron used for notices.
1080 Returns the empty string if no email address.
1082 =cut
1084 sub notice_email_address{
1085 my ( $self ) = @_;
1087 my $which_address = C4::Context->preference("AutoEmailPrimaryAddress");
1088 # if syspref is set to 'first valid' (value == OFF), look up email address
1089 if ( $which_address eq 'OFF' ) {
1090 return $self->first_valid_email_address;
1093 return $self->$which_address || '';
1096 =head3 first_valid_email_address
1098 my $first_valid_email_address = $patron->first_valid_email_address
1100 Return the first valid email address for a patron.
1101 For now, the order is defined as email, emailpro, B_email.
1102 Returns the empty string if the borrower has no email addresses.
1104 =cut
1106 sub first_valid_email_address {
1107 my ($self) = @_;
1109 return $self->email() || $self->emailpro() || $self->B_email() || q{};
1112 =head3 get_club_enrollments
1114 =cut
1116 sub get_club_enrollments {
1117 my ( $self, $return_scalar ) = @_;
1119 my $e = Koha::Club::Enrollments->search( { borrowernumber => $self->borrowernumber(), date_canceled => undef } );
1121 return $e if $return_scalar;
1123 return wantarray ? $e->as_list : $e;
1126 =head3 get_enrollable_clubs
1128 =cut
1130 sub get_enrollable_clubs {
1131 my ( $self, $is_enrollable_from_opac, $return_scalar ) = @_;
1133 my $params;
1134 $params->{is_enrollable_from_opac} = $is_enrollable_from_opac
1135 if $is_enrollable_from_opac;
1136 $params->{is_email_required} = 0 unless $self->first_valid_email_address();
1138 $params->{borrower} = $self;
1140 my $e = Koha::Clubs->get_enrollable($params);
1142 return $e if $return_scalar;
1144 return wantarray ? $e->as_list : $e;
1147 =head3 account_locked
1149 my $is_locked = $patron->account_locked
1151 Return true if the patron has reached the maximum number of login attempts
1152 (see pref FailedLoginAttempts). If login_attempts is < 0, this is interpreted
1153 as an administrative lockout (independent of FailedLoginAttempts; see also
1154 Koha::Patron->lock).
1155 Otherwise return false.
1156 If the pref is not set (empty string, null or 0), the feature is considered as
1157 disabled.
1159 =cut
1161 sub account_locked {
1162 my ($self) = @_;
1163 my $FailedLoginAttempts = C4::Context->preference('FailedLoginAttempts');
1164 return 1 if $FailedLoginAttempts
1165 and $self->login_attempts
1166 and $self->login_attempts >= $FailedLoginAttempts;
1167 return 1 if ($self->login_attempts || 0) < 0; # administrative lockout
1168 return 0;
1171 =head3 can_see_patron_infos
1173 my $can_see = $patron->can_see_patron_infos( $patron );
1175 Return true if the patron (usually the logged in user) can see the patron's infos for a given patron
1177 =cut
1179 sub can_see_patron_infos {
1180 my ( $self, $patron ) = @_;
1181 return unless $patron;
1182 return $self->can_see_patrons_from( $patron->library->branchcode );
1185 =head3 can_see_patrons_from
1187 my $can_see = $patron->can_see_patrons_from( $branchcode );
1189 Return true if the patron (usually the logged in user) can see the patron's infos from a given library
1191 =cut
1193 sub can_see_patrons_from {
1194 my ( $self, $branchcode ) = @_;
1195 my $can = 0;
1196 if ( $self->branchcode eq $branchcode ) {
1197 $can = 1;
1198 } elsif ( $self->has_permission( { borrowers => 'view_borrower_infos_from_any_libraries' } ) ) {
1199 $can = 1;
1200 } elsif ( my $library_groups = $self->library->library_groups ) {
1201 while ( my $library_group = $library_groups->next ) {
1202 if ( $library_group->parent->has_child( $branchcode ) ) {
1203 $can = 1;
1204 last;
1208 return $can;
1211 =head3 libraries_where_can_see_patrons
1213 my $libraries = $patron-libraries_where_can_see_patrons;
1215 Return the list of branchcodes(!) of libraries the patron is allowed to see other patron's infos.
1216 The branchcodes are arbitrarily returned sorted.
1217 We are supposing here that the object is related to the logged in patron (use of C4::Context::only_my_library)
1219 An empty array means no restriction, the patron can see patron's infos from any libraries.
1221 =cut
1223 sub libraries_where_can_see_patrons {
1224 my ( $self ) = @_;
1225 my $userenv = C4::Context->userenv;
1227 return () unless $userenv; # For tests, but userenv should be defined in tests...
1229 my @restricted_branchcodes;
1230 if (C4::Context::only_my_library) {
1231 push @restricted_branchcodes, $self->branchcode;
1233 else {
1234 unless (
1235 $self->has_permission(
1236 { borrowers => 'view_borrower_infos_from_any_libraries' }
1240 my $library_groups = $self->library->library_groups({ ft_hide_patron_info => 1 });
1241 if ( $library_groups->count )
1243 while ( my $library_group = $library_groups->next ) {
1244 my $parent = $library_group->parent;
1245 if ( $parent->has_child( $self->branchcode ) ) {
1246 push @restricted_branchcodes, $parent->children->get_column('branchcode');
1251 @restricted_branchcodes = ( $self->branchcode ) unless @restricted_branchcodes;
1255 @restricted_branchcodes = grep { defined $_ } @restricted_branchcodes;
1256 @restricted_branchcodes = uniq(@restricted_branchcodes);
1257 @restricted_branchcodes = sort(@restricted_branchcodes);
1258 return @restricted_branchcodes;
1261 sub has_permission {
1262 my ( $self, $flagsrequired ) = @_;
1263 return unless $self->userid;
1264 # TODO code from haspermission needs to be moved here!
1265 return C4::Auth::haspermission( $self->userid, $flagsrequired );
1268 =head3 is_adult
1270 my $is_adult = $patron->is_adult
1272 Return true if the patron has a category with a type Adult (A) or Organization (I)
1274 =cut
1276 sub is_adult {
1277 my ( $self ) = @_;
1278 return $self->category->category_type =~ /^(A|I)$/ ? 1 : 0;
1281 =head3 is_child
1283 my $is_child = $patron->is_child
1285 Return true if the patron has a category with a type Child (C)
1287 =cut
1289 sub is_child {
1290 my( $self ) = @_;
1291 return $self->category->category_type eq 'C' ? 1 : 0;
1294 =head3 has_valid_userid
1296 my $patron = Koha::Patrons->find(42);
1297 $patron->userid( $new_userid );
1298 my $has_a_valid_userid = $patron->has_valid_userid
1300 my $patron = Koha::Patron->new( $params );
1301 my $has_a_valid_userid = $patron->has_valid_userid
1303 Return true if the current userid of this patron is valid/unique, otherwise false.
1305 Note that this should be done in $self->store instead and raise an exception if needed.
1307 =cut
1309 sub has_valid_userid {
1310 my ($self) = @_;
1312 return 0 unless $self->userid;
1314 return 0 if ( $self->userid eq C4::Context->config('user') ); # DB user
1316 my $already_exists = Koha::Patrons->search(
1318 userid => $self->userid,
1320 $self->in_storage
1321 ? ( borrowernumber => { '!=' => $self->borrowernumber } )
1322 : ()
1325 )->count;
1326 return $already_exists ? 0 : 1;
1329 =head3 generate_userid
1331 my $patron = Koha::Patron->new( $params );
1332 $patron->generate_userid
1334 Generate a userid using the $surname and the $firstname (if there is a value in $firstname).
1336 Set a generated userid ($firstname.$surname if there is a $firstname, or $surname if there is no value in $firstname) plus offset (0 if the $userid is unique, or a higher numeric value if not unique).
1338 =cut
1340 sub generate_userid {
1341 my ($self) = @_;
1342 my $offset = 0;
1343 my $firstname = $self->firstname // q{};
1344 my $surname = $self->surname // q{};
1345 #The script will "do" the following code and increment the $offset until the generated userid is unique
1346 do {
1347 $firstname =~ s/[[:digit:][:space:][:blank:][:punct:][:cntrl:]]//g;
1348 $surname =~ s/[[:digit:][:space:][:blank:][:punct:][:cntrl:]]//g;
1349 my $userid = lc(($firstname)? "$firstname.$surname" : $surname);
1350 $userid = unac_string('utf-8',$userid);
1351 $userid .= $offset unless $offset == 0;
1352 $self->userid( $userid );
1353 $offset++;
1354 } while (! $self->has_valid_userid );
1356 return $self;
1360 =head3 attributes
1362 my $attributes = $patron->attributes
1364 Return object of Koha::Patron::Attributes type with all attributes set for this patron
1366 =cut
1368 sub attributes {
1369 my ( $self ) = @_;
1370 return Koha::Patron::Attributes->search({
1371 borrowernumber => $self->borrowernumber,
1372 branchcode => $self->branchcode,
1376 =head3 lock
1378 Koha::Patrons->find($id)->lock({ expire => 1, remove => 1 });
1380 Lock and optionally expire a patron account.
1381 Remove holds and article requests if remove flag set.
1382 In order to distinguish from locking by entering a wrong password, let's
1383 call this an administrative lockout.
1385 =cut
1387 sub lock {
1388 my ( $self, $params ) = @_;
1389 $self->login_attempts( ADMINISTRATIVE_LOCKOUT );
1390 if( $params->{expire} ) {
1391 $self->dateexpiry( dt_from_string->subtract(days => 1) );
1393 $self->store;
1394 if( $params->{remove} ) {
1395 $self->holds->delete;
1396 $self->article_requests->delete;
1398 return $self;
1401 =head3 anonymize
1403 Koha::Patrons->find($id)->anonymize;
1405 Anonymize or clear borrower fields. Fields in BorrowerMandatoryField
1406 are randomized, other personal data is cleared too.
1407 Patrons with issues are skipped.
1409 =cut
1411 sub anonymize {
1412 my ( $self ) = @_;
1413 if( $self->_result->issues->count ) {
1414 warn "Exiting anonymize: patron ".$self->borrowernumber." still has issues";
1415 return;
1417 # Mandatory fields come from the corresponding pref, but email fields
1418 # are removed since scrambled email addresses only generate errors
1419 my $mandatory = { map { (lc $_, 1); } grep { !/email/ }
1420 split /\s*\|\s*/, C4::Context->preference('BorrowerMandatoryField') };
1421 $mandatory->{userid} = 1; # needed since sub store does not clear field
1422 my @columns = $self->_result->result_source->columns;
1423 @columns = grep { !/borrowernumber|branchcode|categorycode|^date|password|flags|updated_on|lastseen|lang|login_attempts|anonymized/ } @columns;
1424 push @columns, 'dateofbirth'; # add this date back in
1425 foreach my $col (@columns) {
1426 $self->_anonymize_column($col, $mandatory->{lc $col} );
1428 $self->anonymized(1)->store;
1431 sub _anonymize_column {
1432 my ( $self, $col, $mandatory ) = @_;
1433 my $col_info = $self->_result->result_source->column_info($col);
1434 my $type = $col_info->{data_type};
1435 my $nullable = $col_info->{is_nullable};
1436 my $val;
1437 if( $type =~ /char|text/ ) {
1438 $val = $mandatory
1439 ? Koha::Token->new->generate({ pattern => '\w{10}' })
1440 : $nullable
1441 ? undef
1442 : q{};
1443 } elsif( $type =~ /integer|int$|float|dec|double/ ) {
1444 $val = $nullable ? undef : 0;
1445 } elsif( $type =~ /date|time/ ) {
1446 $val = $nullable ? undef : dt_from_string;
1448 $self->$col($val);
1451 =head3 add_guarantor
1453 my @relationships = $patron->add_guarantor(
1455 borrowernumber => $borrowernumber,
1456 relationships => $relationship,
1460 Adds a new guarantor to a patron.
1462 =cut
1464 sub add_guarantor {
1465 my ( $self, $params ) = @_;
1467 my $guarantor_id = $params->{guarantor_id};
1468 my $relationship = $params->{relationship};
1470 return Koha::Patron::Relationship->new(
1472 guarantee_id => $self->id,
1473 guarantor_id => $guarantor_id,
1474 relationship => $relationship
1476 )->store();
1479 =head3 to_api
1481 my $json = $patron->to_api;
1483 Overloaded method that returns a JSON representation of the Koha::Patron object,
1484 suitable for API output.
1486 =cut
1488 sub to_api {
1489 my ( $self ) = @_;
1491 my $json_patron = $self->SUPER::to_api;
1493 $json_patron->{restricted} = ( $self->is_debarred )
1494 ? Mojo::JSON->true
1495 : Mojo::JSON->false;
1497 return $json_patron;
1500 =head3 to_api_mapping
1502 This method returns the mapping for representing a Koha::Patron object
1503 on the API.
1505 =cut
1507 sub to_api_mapping {
1508 return {
1509 borrowernotes => 'staff_notes',
1510 borrowernumber => 'patron_id',
1511 branchcode => 'library_id',
1512 categorycode => 'category_id',
1513 checkprevcheckout => 'check_previous_checkout',
1514 contactfirstname => undef, # Unused
1515 contactname => undef, # Unused
1516 contactnote => 'altaddress_notes',
1517 contacttitle => undef, # Unused
1518 dateenrolled => 'date_enrolled',
1519 dateexpiry => 'expiry_date',
1520 dateofbirth => 'date_of_birth',
1521 debarred => undef, # replaced by 'restricted'
1522 debarredcomment => undef, # calculated, API consumers will use /restrictions instead
1523 emailpro => 'secondary_email',
1524 flags => undef, # permissions manipulation handled in /permissions
1525 gonenoaddress => 'incorrect_address',
1526 guarantorid => 'guarantor_id',
1527 lastseen => 'last_seen',
1528 lost => 'patron_card_lost',
1529 opacnote => 'opac_notes',
1530 othernames => 'other_name',
1531 password => undef, # password manipulation handled in /password
1532 phonepro => 'secondary_phone',
1533 relationship => 'relationship_type',
1534 sex => 'gender',
1535 smsalertnumber => 'sms_number',
1536 sort1 => 'statistics_1',
1537 sort2 => 'statistics_2',
1538 streetnumber => 'street_number',
1539 streettype => 'street_type',
1540 zipcode => 'postal_code',
1541 B_address => 'altaddress_address',
1542 B_address2 => 'altaddress_address2',
1543 B_city => 'altaddress_city',
1544 B_country => 'altaddress_country',
1545 B_email => 'altaddress_email',
1546 B_phone => 'altaddress_phone',
1547 B_state => 'altaddress_state',
1548 B_streetnumber => 'altaddress_street_number',
1549 B_streettype => 'altaddress_street_type',
1550 B_zipcode => 'altaddress_postal_code',
1551 altcontactaddress1 => 'altcontact_address',
1552 altcontactaddress2 => 'altcontact_address2',
1553 altcontactaddress3 => 'altcontact_city',
1554 altcontactcountry => 'altcontact_country',
1555 altcontactfirstname => 'altcontact_firstname',
1556 altcontactphone => 'altcontact_phone',
1557 altcontactsurname => 'altcontact_surname',
1558 altcontactstate => 'altcontact_state',
1559 altcontactzipcode => 'altcontact_postal_code'
1563 =head2 Internal methods
1565 =head3 _type
1567 =cut
1569 sub _type {
1570 return 'Borrower';
1573 =head1 AUTHORS
1575 Kyle M Hall <kyle@bywatersolutions.com>
1576 Alex Sassmannshausen <alex.sassmannshausen@ptfs-europe.com>
1577 Martin Renvoize <martin.renvoize@ptfs-europe.com>
1579 =cut