Bug 15395: Make QA test script happy
[koha.git] / Koha / Patron.pm
blob5831034bdca8679ca535d9b51c91f6d59fcd2031
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( uniq );
25 use JSON qw( to_json );
26 use Text::Unaccent qw( unac_string );
28 use C4::Accounts;
29 use C4::Context;
30 use C4::Log;
31 use Koha::AuthUtils;
32 use Koha::Checkouts;
33 use Koha::Database;
34 use Koha::DateUtils;
35 use Koha::Exceptions::Password;
36 use Koha::Holds;
37 use Koha::Old::Checkouts;
38 use Koha::Patron::Categories;
39 use Koha::Patron::HouseboundProfile;
40 use Koha::Patron::HouseboundRole;
41 use Koha::Patron::Images;
42 use Koha::Patrons;
43 use Koha::Virtualshelves;
44 use Koha::Club::Enrollments;
45 use Koha::Account;
46 use Koha::Subscription::Routinglists;
48 use base qw(Koha::Object);
50 our $RESULTSET_PATRON_ID_MAPPING = {
51 Accountline => 'borrowernumber',
52 Aqbasketuser => 'borrowernumber',
53 Aqbudget => 'budget_owner_id',
54 Aqbudgetborrower => 'borrowernumber',
55 ArticleRequest => 'borrowernumber',
56 BorrowerAttribute => 'borrowernumber',
57 BorrowerDebarment => 'borrowernumber',
58 BorrowerFile => 'borrowernumber',
59 BorrowerModification => 'borrowernumber',
60 ClubEnrollment => 'borrowernumber',
61 Issue => 'borrowernumber',
62 ItemsLastBorrower => 'borrowernumber',
63 Linktracker => 'borrowernumber',
64 Message => 'borrowernumber',
65 MessageQueue => 'borrowernumber',
66 OldIssue => 'borrowernumber',
67 OldReserve => 'borrowernumber',
68 Rating => 'borrowernumber',
69 Reserve => 'borrowernumber',
70 Review => 'borrowernumber',
71 SearchHistory => 'userid',
72 Statistic => 'borrowernumber',
73 Suggestion => 'suggestedby',
74 TagAll => 'borrowernumber',
75 Virtualshelfcontent => 'borrowernumber',
76 Virtualshelfshare => 'borrowernumber',
77 Virtualshelve => 'owner',
80 =head1 NAME
82 Koha::Patron - Koha Patron Object class
84 =head1 API
86 =head2 Class Methods
88 =cut
90 =head3 new
92 =cut
94 sub new {
95 my ( $class, $params ) = @_;
97 return $class->SUPER::new($params);
100 =head3 fixup_cardnumber
102 Autogenerate next cardnumber from highest value found in database
104 =cut
106 sub fixup_cardnumber {
107 my ( $self ) = @_;
108 my $max = Koha::Patrons->search({
109 cardnumber => {-regexp => '^-?[0-9]+$'}
110 }, {
111 select => \'CAST(cardnumber AS SIGNED)',
112 as => ['cast_cardnumber']
113 })->_resultset->get_column('cast_cardnumber')->max;
114 $self->cardnumber(($max || 0) +1);
117 =head3 trim_whitespace
119 trim whitespace from data which has some non-whitespace in it.
120 Could be moved to Koha::Object if need to be reused
122 =cut
124 sub trim_whitespaces {
125 my( $self ) = @_;
127 my $schema = Koha::Database->new->schema;
128 my @columns = $schema->source($self->_type)->columns;
130 for my $column( @columns ) {
131 my $value = $self->$column;
132 if ( defined $value ) {
133 $value =~ s/^\s*|\s*$//g;
134 $self->$column($value);
137 return $self;
140 =head3 plain_text_password
142 $patron->plain_text_password( $password );
144 stores a copy of the unencrypted password in the object
145 for use in code before encrypting for db
147 =cut
149 sub plain_text_password {
150 my ( $self, $password ) = @_;
151 if ( $password ) {
152 $self->{_plain_text_password} = $password;
153 return $self;
155 return $self->{_plain_text_password}
156 if $self->{_plain_text_password};
158 return;
161 =head3 store
163 Patron specific store method to cleanup record
164 and do other necessary things before saving
165 to db
167 =cut
169 sub store {
170 my ($self) = @_;
172 $self->_result->result_source->schema->txn_do(
173 sub {
174 if (
175 C4::Context->preference("autoMemberNum")
176 and ( not defined $self->cardnumber
177 or $self->cardnumber eq '' )
180 # Warning: The caller is responsible for locking the members table in write
181 # mode, to avoid database corruption.
182 # We are in a transaction but the table is not locked
183 $self->fixup_cardnumber;
186 unless( $self->category->in_storage ) {
187 Koha::Exceptions::Object::FKConstraint->throw(
188 broken_fk => 'categorycode',
189 value => $self->categorycode,
193 $self->trim_whitespaces;
195 # We don't want invalid dates in the db (mysql has a bad habit of inserting 0000-00-00)
196 $self->dateofbirth(undef) unless $self->dateofbirth;
197 $self->debarred(undef) unless $self->debarred;
198 $self->date_renewed(undef) unless $self->date_renewed;
199 $self->lastseen(undef) unless $self->lastseen;
201 if ( defined $self->updated_on and not $self->updated_on ) {
202 $self->updated_on(undef);
205 # Set default values if not set
206 $self->sms_provider_id(undef) unless $self->sms_provider_id;
207 $self->guarantorid(undef) unless $self->guarantorid;
209 # If flags == 0 or flags == '' => no permission
210 $self->flags(undef) unless $self->flags;
212 # tinyint or int
213 $self->gonenoaddress(0) unless $self->gonenoaddress;
214 $self->login_attempts(0) unless $self->login_attempts;
215 $self->privacy_guarantor_checkouts(0) unless $self->privacy_guarantor_checkouts;
216 $self->lost(0) unless $self->lost;
218 unless ( $self->in_storage ) { #AddMember
220 # Generate a valid userid/login if needed
221 $self->generate_userid
222 if not $self->userid or not $self->has_valid_userid;
224 # Add expiration date if it isn't already there
225 unless ( $self->dateexpiry ) {
226 $self->dateexpiry( $self->category->get_expiry_date );
229 # Add enrollment date if it isn't already there
230 unless ( $self->dateenrolled ) {
231 $self->dateenrolled(dt_from_string);
234 # Set the privacy depending on the patron's category
235 my $default_privacy = $self->category->default_privacy || q{};
236 $default_privacy =
237 $default_privacy eq 'default' ? 1
238 : $default_privacy eq 'never' ? 2
239 : $default_privacy eq 'forever' ? 0
240 : undef;
241 $self->privacy($default_privacy);
243 unless ( defined $self->privacy_guarantor_checkouts ) {
244 $self->privacy_guarantor_checkouts(0);
247 # Make a copy of the plain text password for later use
248 $self->plain_text_password( $self->password );
250 # Create a disabled account if no password provided
251 $self->password( $self->password
252 ? Koha::AuthUtils::hash_password( $self->password )
253 : '!' );
255 $self->borrowernumber(undef);
257 $self = $self->SUPER::store;
259 $self->add_enrolment_fee_if_needed;
261 logaction( "MEMBERS", "CREATE", $self->borrowernumber, "" )
262 if C4::Context->preference("BorrowersLog");
264 else { #ModMember
266 # Come from ModMember, but should not be possible (?)
267 $self->dateenrolled(undef) unless $self->dateenrolled;
268 $self->dateexpiry(undef) unless $self->dateexpiry;
271 my $self_from_storage = $self->get_from_storage;
272 # FIXME We should not deal with that here, callers have to do this job
273 # Moved from ModMember to prevent regressions
274 unless ( $self->userid ) {
275 my $stored_userid = $self_from_storage->userid;
276 $self->userid($stored_userid);
279 # Password must be updated using $self->update_password
280 $self->password($self_from_storage->password);
282 if ( C4::Context->preference('FeeOnChangePatronCategory')
283 and $self->category->categorycode ne
284 $self_from_storage->category->categorycode )
286 $self->add_enrolment_fee_if_needed;
289 my $borrowers_log = C4::Context->preference("BorrowersLog");
290 my $previous_cardnumber = $self_from_storage->cardnumber;
291 if ($borrowers_log
292 && ( !defined $previous_cardnumber
293 || $previous_cardnumber ne $self->cardnumber )
296 logaction(
297 "MEMBERS",
298 "MODIFY",
299 $self->borrowernumber,
300 to_json(
302 cardnumber_replaced => {
303 previous_cardnumber => $previous_cardnumber,
304 new_cardnumber => $self->cardnumber,
307 { utf8 => 1, pretty => 1 }
312 logaction( "MEMBERS", "MODIFY", $self->borrowernumber,
313 "UPDATE (executed w/ arg: " . $self->borrowernumber . ")" )
314 if $borrowers_log;
316 $self = $self->SUPER::store;
320 return $self;
323 =head3 delete
325 $patron->delete
327 Delete patron's holds, lists and finally the patron.
329 Lists owned by the borrower are deleted, but entries from the borrower to
330 other lists are kept.
332 =cut
334 sub delete {
335 my ($self) = @_;
337 my $deleted;
338 $self->_result->result_source->schema->txn_do(
339 sub {
340 # Delete Patron's holds
341 $self->holds->delete;
343 # Delete all lists and all shares of this borrower
344 # Consistent with the approach Koha uses on deleting individual lists
345 # Note that entries in virtualshelfcontents added by this borrower to
346 # lists of others will be handled by a table constraint: the borrower
347 # is set to NULL in those entries.
348 # NOTE:
349 # We could handle the above deletes via a constraint too.
350 # But a new BZ report 11889 has been opened to discuss another approach.
351 # Instead of deleting we could also disown lists (based on a pref).
352 # In that way we could save shared and public lists.
353 # The current table constraints support that idea now.
354 # This pref should then govern the results of other routines/methods such as
355 # Koha::Virtualshelf->new->delete too.
356 # FIXME Could be $patron->get_lists
357 $_->delete for Koha::Virtualshelves->search( { owner => $self->borrowernumber } );
359 $deleted = $self->SUPER::delete;
361 logaction( "MEMBERS", "DELETE", $self->borrowernumber, "" ) if C4::Context->preference("BorrowersLog");
364 return $deleted;
368 =head3 category
370 my $patron_category = $patron->category
372 Return the patron category for this patron
374 =cut
376 sub category {
377 my ( $self ) = @_;
378 return Koha::Patron::Category->_new_from_dbic( $self->_result->categorycode );
381 =head3 guarantor
383 Returns a Koha::Patron object for this patron's guarantor
385 =cut
387 sub guarantor {
388 my ( $self ) = @_;
390 return unless $self->guarantorid();
392 return Koha::Patrons->find( $self->guarantorid() );
395 sub image {
396 my ( $self ) = @_;
398 return scalar Koha::Patron::Images->find( $self->borrowernumber );
401 sub library {
402 my ( $self ) = @_;
403 return Koha::Library->_new_from_dbic($self->_result->branchcode);
406 =head3 guarantees
408 Returns the guarantees (list of Koha::Patron) of this patron
410 =cut
412 sub guarantees {
413 my ( $self ) = @_;
415 return Koha::Patrons->search( { guarantorid => $self->borrowernumber }, { order_by => { -asc => ['surname','firstname'] } } );
418 =head3 housebound_profile
420 Returns the HouseboundProfile associated with this patron.
422 =cut
424 sub housebound_profile {
425 my ( $self ) = @_;
426 my $profile = $self->_result->housebound_profile;
427 return Koha::Patron::HouseboundProfile->_new_from_dbic($profile)
428 if ( $profile );
429 return;
432 =head3 housebound_role
434 Returns the HouseboundRole associated with this patron.
436 =cut
438 sub housebound_role {
439 my ( $self ) = @_;
441 my $role = $self->_result->housebound_role;
442 return Koha::Patron::HouseboundRole->_new_from_dbic($role) if ( $role );
443 return;
446 =head3 siblings
448 Returns the siblings of this patron.
450 =cut
452 sub siblings {
453 my ( $self ) = @_;
455 my $guarantor = $self->guarantor;
457 return unless $guarantor;
459 return Koha::Patrons->search(
461 guarantorid => {
462 '!=' => undef,
463 '=' => $guarantor->id,
465 borrowernumber => {
466 '!=' => $self->borrowernumber,
472 =head3 merge_with
474 my $patron = Koha::Patrons->find($id);
475 $patron->merge_with( \@patron_ids );
477 This subroutine merges a list of patrons into the patron record. This is accomplished by finding
478 all related patron ids for the patrons to be merged in other tables and changing the ids to be that
479 of the keeper patron.
481 =cut
483 sub merge_with {
484 my ( $self, $patron_ids ) = @_;
486 my @patron_ids = @{ $patron_ids };
488 # Ensure the keeper isn't in the list of patrons to merge
489 @patron_ids = grep { $_ ne $self->id } @patron_ids;
491 my $schema = Koha::Database->new()->schema();
493 my $results;
495 $self->_result->result_source->schema->txn_do( sub {
496 foreach my $patron_id (@patron_ids) {
497 my $patron = Koha::Patrons->find( $patron_id );
499 next unless $patron;
501 # Unbless for safety, the patron will end up being deleted
502 $results->{merged}->{$patron_id}->{patron} = $patron->unblessed;
504 while (my ($r, $field) = each(%$RESULTSET_PATRON_ID_MAPPING)) {
505 my $rs = $schema->resultset($r)->search({ $field => $patron_id });
506 $results->{merged}->{ $patron_id }->{updated}->{$r} = $rs->count();
507 $rs->update({ $field => $self->id });
510 $patron->move_to_deleted();
511 $patron->delete();
515 return $results;
520 =head3 wants_check_for_previous_checkout
522 $wants_check = $patron->wants_check_for_previous_checkout;
524 Return 1 if Koha needs to perform PrevIssue checking, else 0.
526 =cut
528 sub wants_check_for_previous_checkout {
529 my ( $self ) = @_;
530 my $syspref = C4::Context->preference("checkPrevCheckout");
532 # Simple cases
533 ## Hard syspref trumps all
534 return 1 if ($syspref eq 'hardyes');
535 return 0 if ($syspref eq 'hardno');
536 ## Now, patron pref trumps all
537 return 1 if ($self->checkprevcheckout eq 'yes');
538 return 0 if ($self->checkprevcheckout eq 'no');
540 # More complex: patron inherits -> determine category preference
541 my $checkPrevCheckoutByCat = $self->category->checkprevcheckout;
542 return 1 if ($checkPrevCheckoutByCat eq 'yes');
543 return 0 if ($checkPrevCheckoutByCat eq 'no');
545 # Finally: category preference is inherit, default to 0
546 if ($syspref eq 'softyes') {
547 return 1;
548 } else {
549 return 0;
553 =head3 do_check_for_previous_checkout
555 $do_check = $patron->do_check_for_previous_checkout($item);
557 Return 1 if the bib associated with $ITEM has previously been checked out to
558 $PATRON, 0 otherwise.
560 =cut
562 sub do_check_for_previous_checkout {
563 my ( $self, $item ) = @_;
565 # Find all items for bib and extract item numbers.
566 my @items = Koha::Items->search({biblionumber => $item->{biblionumber}});
567 my @item_nos;
568 foreach my $item (@items) {
569 push @item_nos, $item->itemnumber;
572 # Create (old)issues search criteria
573 my $criteria = {
574 borrowernumber => $self->borrowernumber,
575 itemnumber => \@item_nos,
578 # Check current issues table
579 my $issues = Koha::Checkouts->search($criteria);
580 return 1 if $issues->count; # 0 || N
582 # Check old issues table
583 my $old_issues = Koha::Old::Checkouts->search($criteria);
584 return $old_issues->count; # 0 || N
587 =head3 is_debarred
589 my $debarment_expiration = $patron->is_debarred;
591 Returns the date a patron debarment will expire, or undef if the patron is not
592 debarred
594 =cut
596 sub is_debarred {
597 my ($self) = @_;
599 return unless $self->debarred;
600 return $self->debarred
601 if $self->debarred =~ '^9999'
602 or dt_from_string( $self->debarred ) > dt_from_string;
603 return;
606 =head3 is_expired
608 my $is_expired = $patron->is_expired;
610 Returns 1 if the patron is expired or 0;
612 =cut
614 sub is_expired {
615 my ($self) = @_;
616 return 0 unless $self->dateexpiry;
617 return 0 if $self->dateexpiry =~ '^9999';
618 return 1 if dt_from_string( $self->dateexpiry ) < dt_from_string->truncate( to => 'day' );
619 return 0;
622 =head3 is_going_to_expire
624 my $is_going_to_expire = $patron->is_going_to_expire;
626 Returns 1 if the patron is going to expired, depending on the NotifyBorrowerDeparture pref or 0
628 =cut
630 sub is_going_to_expire {
631 my ($self) = @_;
633 my $delay = C4::Context->preference('NotifyBorrowerDeparture') || 0;
635 return 0 unless $delay;
636 return 0 unless $self->dateexpiry;
637 return 0 if $self->dateexpiry =~ '^9999';
638 return 1 if dt_from_string( $self->dateexpiry )->subtract( days => $delay ) < dt_from_string->truncate( to => 'day' );
639 return 0;
642 =head3 update_password
644 my $updated = $patron->update_password( $userid, $password );
646 Update the userid and the password of a patron.
647 If the userid already exists, returns and let DBIx::Class warns
648 This will add an entry to action_logs if BorrowersLog is set.
650 =cut
652 sub update_password {
653 my ( $self, $userid, $password ) = @_;
654 eval { $self->userid($userid)->store; };
655 return if $@; # Make sure the userid is not already in used by another patron
657 return 0 if $password eq '****' or $password eq '';
659 my $digest = Koha::AuthUtils::hash_password($password);
660 $self->update(
662 password => $digest,
663 login_attempts => 0,
667 logaction( "MEMBERS", "CHANGE PASS", $self->borrowernumber, "" ) if C4::Context->preference("BorrowersLog");
668 return $digest;
671 =head3 set_password
673 $patron->set_password( $plain_text_password );
675 Set the patron's password.
677 =head4 Exceptions
679 The passed string is validated against the current password enforcement policy.
680 Exceptions are thrown if the password is not good enough.
682 =over 4
684 =item Koha::Exceptions::Password::TooShort
686 =item Koha::Exceptions::Password::WhitespaceCharacters
688 =item Koha::Exceptions::Password::TooWeak
690 =back
692 =cut
694 sub set_password {
695 my ( $self, $password ) = @_;
697 my ( $is_valid, $error ) = Koha::AuthUtils::is_password_valid( $password );
699 if ( !$is_valid ) {
700 if ( $error eq 'too_short' ) {
701 my $min_length = C4::Context->preference('minPasswordLength');
702 $min_length = 3 if not $min_length or $min_length < 3;
704 my $password_length = length($password);
705 Koha::Exceptions::Password::TooShort->throw(
706 { length => $password_length, min_length => $min_length } );
708 elsif ( $error eq 'has_whitespaces' ) {
709 Koha::Exceptions::Password::WhitespaceCharacters->throw();
711 elsif ( $error eq 'too_weak' ) {
712 Koha::Exceptions::Password::TooWeak->throw();
716 my $digest = Koha::AuthUtils::hash_password($password);
717 $self->update(
718 { password => $digest,
719 login_attempts => 0,
723 logaction( "MEMBERS", "CHANGE PASS", $self->borrowernumber, "" )
724 if C4::Context->preference("BorrowersLog");
726 return $self;
730 =head3 renew_account
732 my $new_expiry_date = $patron->renew_account
734 Extending the subscription to the expiry date.
736 =cut
738 sub renew_account {
739 my ($self) = @_;
740 my $date;
741 if ( C4::Context->preference('BorrowerRenewalPeriodBase') eq 'combination' ) {
742 $date = ( dt_from_string gt dt_from_string( $self->dateexpiry ) ) ? dt_from_string : dt_from_string( $self->dateexpiry );
743 } else {
744 $date =
745 C4::Context->preference('BorrowerRenewalPeriodBase') eq 'dateexpiry'
746 ? dt_from_string( $self->dateexpiry )
747 : dt_from_string;
749 my $expiry_date = $self->category->get_expiry_date($date);
751 $self->dateexpiry($expiry_date);
752 $self->date_renewed( dt_from_string() );
753 $self->store();
755 $self->add_enrolment_fee_if_needed;
757 logaction( "MEMBERS", "RENEW", $self->borrowernumber, "Membership renewed" ) if C4::Context->preference("BorrowersLog");
758 return dt_from_string( $expiry_date )->truncate( to => 'day' );
761 =head3 has_overdues
763 my $has_overdues = $patron->has_overdues;
765 Returns the number of patron's overdues
767 =cut
769 sub has_overdues {
770 my ($self) = @_;
771 my $dtf = Koha::Database->new->schema->storage->datetime_parser;
772 return $self->_result->issues->search({ date_due => { '<' => $dtf->format_datetime( dt_from_string() ) } })->count;
775 =head3 track_login
777 $patron->track_login;
778 $patron->track_login({ force => 1 });
780 Tracks a (successful) login attempt.
781 The preference TrackLastPatronActivity must be enabled. Or you
782 should pass the force parameter.
784 =cut
786 sub track_login {
787 my ( $self, $params ) = @_;
788 return if
789 !$params->{force} &&
790 !C4::Context->preference('TrackLastPatronActivity');
791 $self->lastseen( dt_from_string() )->store;
794 =head3 move_to_deleted
796 my $is_moved = $patron->move_to_deleted;
798 Move a patron to the deletedborrowers table.
799 This can be done before deleting a patron, to make sure the data are not completely deleted.
801 =cut
803 sub move_to_deleted {
804 my ($self) = @_;
805 my $patron_infos = $self->unblessed;
806 delete $patron_infos->{updated_on}; #This ensures the updated_on date in deletedborrowers will be set to the current timestamp
807 return Koha::Database->new->schema->resultset('Deletedborrower')->create($patron_infos);
810 =head3 article_requests
812 my @requests = $borrower->article_requests();
813 my $requests = $borrower->article_requests();
815 Returns either a list of ArticleRequests objects,
816 or an ArtitleRequests object, depending on the
817 calling context.
819 =cut
821 sub article_requests {
822 my ( $self ) = @_;
824 $self->{_article_requests} ||= Koha::ArticleRequests->search({ borrowernumber => $self->borrowernumber() });
826 return $self->{_article_requests};
829 =head3 article_requests_current
831 my @requests = $patron->article_requests_current
833 Returns the article requests associated with this patron that are incomplete
835 =cut
837 sub article_requests_current {
838 my ( $self ) = @_;
840 $self->{_article_requests_current} ||= Koha::ArticleRequests->search(
842 borrowernumber => $self->id(),
843 -or => [
844 { status => Koha::ArticleRequest::Status::Pending },
845 { status => Koha::ArticleRequest::Status::Processing }
850 return $self->{_article_requests_current};
853 =head3 article_requests_finished
855 my @requests = $biblio->article_requests_finished
857 Returns the article requests associated with this patron that are completed
859 =cut
861 sub article_requests_finished {
862 my ( $self, $borrower ) = @_;
864 $self->{_article_requests_finished} ||= Koha::ArticleRequests->search(
866 borrowernumber => $self->id(),
867 -or => [
868 { status => Koha::ArticleRequest::Status::Completed },
869 { status => Koha::ArticleRequest::Status::Canceled }
874 return $self->{_article_requests_finished};
877 =head3 add_enrolment_fee_if_needed
879 my $enrolment_fee = $patron->add_enrolment_fee_if_needed;
881 Add enrolment fee for a patron if needed.
883 =cut
885 sub add_enrolment_fee_if_needed {
886 my ($self) = @_;
887 my $enrolment_fee = $self->category->enrolmentfee;
888 if ( $enrolment_fee && $enrolment_fee > 0 ) {
889 # insert fee in patron debts
890 C4::Accounts::manualinvoice( $self->borrowernumber, '', '', 'A', $enrolment_fee );
892 return $enrolment_fee || 0;
895 =head3 checkouts
897 my $checkouts = $patron->checkouts
899 =cut
901 sub checkouts {
902 my ($self) = @_;
903 my $checkouts = $self->_result->issues;
904 return Koha::Checkouts->_new_from_dbic( $checkouts );
907 =head3 pending_checkouts
909 my $pending_checkouts = $patron->pending_checkouts
911 This method will return the same as $self->checkouts, but with a prefetch on
912 items, biblio and biblioitems.
914 It has been introduced to replaced the C4::Members::GetPendingIssues subroutine
916 It should not be used directly, prefer to access fields you need instead of
917 retrieving all these fields in one go.
920 =cut
922 sub pending_checkouts {
923 my( $self ) = @_;
924 my $checkouts = $self->_result->issues->search(
927 order_by => [
928 { -desc => 'me.timestamp' },
929 { -desc => 'issuedate' },
930 { -desc => 'issue_id' }, # Sort by issue_id should be enough
932 prefetch => { item => { biblio => 'biblioitems' } },
935 return Koha::Checkouts->_new_from_dbic( $checkouts );
938 =head3 old_checkouts
940 my $old_checkouts = $patron->old_checkouts
942 =cut
944 sub old_checkouts {
945 my ($self) = @_;
946 my $old_checkouts = $self->_result->old_issues;
947 return Koha::Old::Checkouts->_new_from_dbic( $old_checkouts );
950 =head3 get_overdues
952 my $overdue_items = $patron->get_overdues
954 Return the overdue items
956 =cut
958 sub get_overdues {
959 my ($self) = @_;
960 my $dtf = Koha::Database->new->schema->storage->datetime_parser;
961 return $self->checkouts->search(
963 'me.date_due' => { '<' => $dtf->format_datetime(dt_from_string) },
966 prefetch => { item => { biblio => 'biblioitems' } },
971 =head3 get_routing_lists
973 my @routinglists = $patron->get_routing_lists
975 Returns the routing lists a patron is subscribed to.
977 =cut
979 sub get_routing_lists {
980 my ($self) = @_;
981 my $routing_list_rs = $self->_result->subscriptionroutinglists;
982 return Koha::Subscription::Routinglists->_new_from_dbic($routing_list_rs);
985 =head3 get_age
987 my $age = $patron->get_age
989 Return the age of the patron
991 =cut
993 sub get_age {
994 my ($self) = @_;
995 my $today_str = dt_from_string->strftime("%Y-%m-%d");
996 return unless $self->dateofbirth;
997 my $dob_str = dt_from_string( $self->dateofbirth )->strftime("%Y-%m-%d");
999 my ( $dob_y, $dob_m, $dob_d ) = split /-/, $dob_str;
1000 my ( $today_y, $today_m, $today_d ) = split /-/, $today_str;
1002 my $age = $today_y - $dob_y;
1003 if ( $dob_m . $dob_d > $today_m . $today_d ) {
1004 $age--;
1007 return $age;
1010 =head3 account
1012 my $account = $patron->account
1014 =cut
1016 sub account {
1017 my ($self) = @_;
1018 return Koha::Account->new( { patron_id => $self->borrowernumber } );
1021 =head3 holds
1023 my $holds = $patron->holds
1025 Return all the holds placed by this patron
1027 =cut
1029 sub holds {
1030 my ($self) = @_;
1031 my $holds_rs = $self->_result->reserves->search( {}, { order_by => 'reservedate' } );
1032 return Koha::Holds->_new_from_dbic($holds_rs);
1035 =head3 old_holds
1037 my $old_holds = $patron->old_holds
1039 Return all the historical holds for this patron
1041 =cut
1043 sub old_holds {
1044 my ($self) = @_;
1045 my $old_holds_rs = $self->_result->old_reserves->search( {}, { order_by => 'reservedate' } );
1046 return Koha::Old::Holds->_new_from_dbic($old_holds_rs);
1049 =head3 notice_email_address
1051 my $email = $patron->notice_email_address;
1053 Return the email address of patron used for notices.
1054 Returns the empty string if no email address.
1056 =cut
1058 sub notice_email_address{
1059 my ( $self ) = @_;
1061 my $which_address = C4::Context->preference("AutoEmailPrimaryAddress");
1062 # if syspref is set to 'first valid' (value == OFF), look up email address
1063 if ( $which_address eq 'OFF' ) {
1064 return $self->first_valid_email_address;
1067 return $self->$which_address || '';
1070 =head3 first_valid_email_address
1072 my $first_valid_email_address = $patron->first_valid_email_address
1074 Return the first valid email address for a patron.
1075 For now, the order is defined as email, emailpro, B_email.
1076 Returns the empty string if the borrower has no email addresses.
1078 =cut
1080 sub first_valid_email_address {
1081 my ($self) = @_;
1083 return $self->email() || $self->emailpro() || $self->B_email() || q{};
1086 =head3 get_club_enrollments
1088 =cut
1090 sub get_club_enrollments {
1091 my ( $self, $return_scalar ) = @_;
1093 my $e = Koha::Club::Enrollments->search( { borrowernumber => $self->borrowernumber(), date_canceled => undef } );
1095 return $e if $return_scalar;
1097 return wantarray ? $e->as_list : $e;
1100 =head3 get_enrollable_clubs
1102 =cut
1104 sub get_enrollable_clubs {
1105 my ( $self, $is_enrollable_from_opac, $return_scalar ) = @_;
1107 my $params;
1108 $params->{is_enrollable_from_opac} = $is_enrollable_from_opac
1109 if $is_enrollable_from_opac;
1110 $params->{is_email_required} = 0 unless $self->first_valid_email_address();
1112 $params->{borrower} = $self;
1114 my $e = Koha::Clubs->get_enrollable($params);
1116 return $e if $return_scalar;
1118 return wantarray ? $e->as_list : $e;
1121 =head3 account_locked
1123 my $is_locked = $patron->account_locked
1125 Return true if the patron has reach the maximum number of login attempts (see pref FailedLoginAttempts).
1126 Otherwise return false.
1127 If the pref is not set (empty string, null or 0), the feature is considered as disabled.
1129 =cut
1131 sub account_locked {
1132 my ($self) = @_;
1133 my $FailedLoginAttempts = C4::Context->preference('FailedLoginAttempts');
1134 return ( $FailedLoginAttempts
1135 and $self->login_attempts
1136 and $self->login_attempts >= $FailedLoginAttempts )? 1 : 0;
1139 =head3 can_see_patron_infos
1141 my $can_see = $patron->can_see_patron_infos( $patron );
1143 Return true if the patron (usually the logged in user) can see the patron's infos for a given patron
1145 =cut
1147 sub can_see_patron_infos {
1148 my ( $self, $patron ) = @_;
1149 return $self->can_see_patrons_from( $patron->library->branchcode );
1152 =head3 can_see_patrons_from
1154 my $can_see = $patron->can_see_patrons_from( $branchcode );
1156 Return true if the patron (usually the logged in user) can see the patron's infos from a given library
1158 =cut
1160 sub can_see_patrons_from {
1161 my ( $self, $branchcode ) = @_;
1162 my $can = 0;
1163 if ( $self->branchcode eq $branchcode ) {
1164 $can = 1;
1165 } elsif ( $self->has_permission( { borrowers => 'view_borrower_infos_from_any_libraries' } ) ) {
1166 $can = 1;
1167 } elsif ( my $library_groups = $self->library->library_groups ) {
1168 while ( my $library_group = $library_groups->next ) {
1169 if ( $library_group->parent->has_child( $branchcode ) ) {
1170 $can = 1;
1171 last;
1175 return $can;
1178 =head3 libraries_where_can_see_patrons
1180 my $libraries = $patron-libraries_where_can_see_patrons;
1182 Return the list of branchcodes(!) of libraries the patron is allowed to see other patron's infos.
1183 The branchcodes are arbitrarily returned sorted.
1184 We are supposing here that the object is related to the logged in patron (use of C4::Context::only_my_library)
1186 An empty array means no restriction, the patron can see patron's infos from any libraries.
1188 =cut
1190 sub libraries_where_can_see_patrons {
1191 my ( $self ) = @_;
1192 my $userenv = C4::Context->userenv;
1194 return () unless $userenv; # For tests, but userenv should be defined in tests...
1196 my @restricted_branchcodes;
1197 if (C4::Context::only_my_library) {
1198 push @restricted_branchcodes, $self->branchcode;
1200 else {
1201 unless (
1202 $self->has_permission(
1203 { borrowers => 'view_borrower_infos_from_any_libraries' }
1207 my $library_groups = $self->library->library_groups({ ft_hide_patron_info => 1 });
1208 if ( $library_groups->count )
1210 while ( my $library_group = $library_groups->next ) {
1211 my $parent = $library_group->parent;
1212 if ( $parent->has_child( $self->branchcode ) ) {
1213 push @restricted_branchcodes, $parent->children->get_column('branchcode');
1218 @restricted_branchcodes = ( $self->branchcode ) unless @restricted_branchcodes;
1222 @restricted_branchcodes = grep { defined $_ } @restricted_branchcodes;
1223 @restricted_branchcodes = uniq(@restricted_branchcodes);
1224 @restricted_branchcodes = sort(@restricted_branchcodes);
1225 return @restricted_branchcodes;
1228 sub has_permission {
1229 my ( $self, $flagsrequired ) = @_;
1230 return unless $self->userid;
1231 # TODO code from haspermission needs to be moved here!
1232 return C4::Auth::haspermission( $self->userid, $flagsrequired );
1235 =head3 is_adult
1237 my $is_adult = $patron->is_adult
1239 Return true if the patron has a category with a type Adult (A) or Organization (I)
1241 =cut
1243 sub is_adult {
1244 my ( $self ) = @_;
1245 return $self->category->category_type =~ /^(A|I)$/ ? 1 : 0;
1248 =head3 is_child
1250 my $is_child = $patron->is_child
1252 Return true if the patron has a category with a type Child (C)
1254 =cut
1255 sub is_child {
1256 my( $self ) = @_;
1257 return $self->category->category_type eq 'C' ? 1 : 0;
1260 =head3 has_valid_userid
1262 my $patron = Koha::Patrons->find(42);
1263 $patron->userid( $new_userid );
1264 my $has_a_valid_userid = $patron->has_valid_userid
1266 my $patron = Koha::Patron->new( $params );
1267 my $has_a_valid_userid = $patron->has_valid_userid
1269 Return true if the current userid of this patron is valid/unique, otherwise false.
1271 Note that this should be done in $self->store instead and raise an exception if needed.
1273 =cut
1275 sub has_valid_userid {
1276 my ($self) = @_;
1278 return 0 unless $self->userid;
1280 return 0 if ( $self->userid eq C4::Context->config('user') ); # DB user
1282 my $already_exists = Koha::Patrons->search(
1284 userid => $self->userid,
1286 $self->in_storage
1287 ? ( borrowernumber => { '!=' => $self->borrowernumber } )
1288 : ()
1291 )->count;
1292 return $already_exists ? 0 : 1;
1295 =head3 generate_userid
1297 my $patron = Koha::Patron->new( $params );
1298 $patron->generate_userid
1300 Generate a userid using the $surname and the $firstname (if there is a value in $firstname).
1302 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).
1304 =cut
1306 sub generate_userid {
1307 my ($self) = @_;
1308 my $offset = 0;
1309 my $firstname = $self->firstname // q{};
1310 my $surname = $self->surname // q{};
1311 #The script will "do" the following code and increment the $offset until the generated userid is unique
1312 do {
1313 $firstname =~ s/[[:digit:][:space:][:blank:][:punct:][:cntrl:]]//g;
1314 $surname =~ s/[[:digit:][:space:][:blank:][:punct:][:cntrl:]]//g;
1315 my $userid = lc(($firstname)? "$firstname.$surname" : $surname);
1316 $userid = unac_string('utf-8',$userid);
1317 $userid .= $offset unless $offset == 0;
1318 $self->userid( $userid );
1319 $offset++;
1320 } while (! $self->has_valid_userid );
1322 return $self;
1326 =head2 Internal methods
1328 =head3 _type
1330 =cut
1332 sub _type {
1333 return 'Borrower';
1336 =head1 AUTHOR
1338 Kyle M Hall <kyle@bywatersolutions.com>
1339 Alex Sassmannshausen <alex.sassmannshausen@ptfs-europe.com>
1341 =cut