Koha/Patron.pm

   1 package Koha::Patron;
   2
   3 # Copyright ByWater Solutions 2014
   4 # Copyright PTFS Europe 2016
   5 #
   6 # This file is part of Koha.
   7 #
   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.
  12 #
  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.
  16 #
  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.
  20
  21 use Modern::Perl;
  22
  23 use Carp;
  24 use List::MoreUtils qw( uniq );
  25 use JSON qw( to_json );
  26 use Text::Unaccent qw( unac_string );
  27
  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;
  47
  48 use base qw(Koha::Object);
  49
  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',
  78 };
  79
  80 =head1 NAME
  81
  82 Koha::Patron - Koha Patron Object class
  83
  84 =head1 API
  85
  86 =head2 Class Methods
  87
  88 =cut
  89
  90 =head3 new
  91
  92 =cut
  93
  94 sub new {
  95     my ( $class, $params ) = @_;
  96
  97     return $class->SUPER::new($params);
  98 }
  99
 100 =head3 fixup_cardnumber
 101
 102 Autogenerate next cardnumber from highest value found in database
 103
 104 =cut
 105
 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);
 115 }
 116
 117 =head3 trim_whitespace
 118
 119 trim whitespace from data which has some non-whitespace in it.
 120 Could be moved to Koha::Object if need to be reused
 121
 122 =cut
 123
 124 sub trim_whitespaces {
 125     my( $self ) = @_;
 126
 127     my $schema  = Koha::Database->new->schema;
 128     my @columns = $schema->source($self->_type)->columns;
 129
 130     for my $column( @columns ) {
 131         my $value = $self->$column;
 132         if ( defined $value ) {
 133             $value =~ s/^\s*|\s*$//g;
 134             $self->$column($value);
 135         }
 136     }
 137     return $self;
 138 }
 139
 140 =head3 plain_text_password
 141
 142 $patron->plain_text_password( $password );
 143
 144 stores a copy of the unencrypted password in the object
 145 for use in code before encrypting for db
 146
 147 =cut
 148
 149 sub plain_text_password {
 150     my ( $self, $password ) = @_;
 151     if ( $password ) {
 152         $self->{_plain_text_password} = $password;
 153         return $self;
 154     }
 155     return $self->{_plain_text_password}
 156         if $self->{_plain_text_password};
 157
 158     return;
 159 }
 160
 161 =head3 store
 162
 163 Patron specific store method to cleanup record
 164 and do other necessary things before saving
 165 to db
 166
 167 =cut
 168
 169 sub store {
 170     my ($self) = @_;
 171
 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 '' )
 178               )
 179             {
 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;
 184             }
 185
 186             unless( $self->category->in_storage ) {
 187                 Koha::Exceptions::Object::FKConstraint->throw(
 188                     broken_fk => 'categorycode',
 189                     value     => $self->categorycode,
 190                 );
 191             }
 192
 193             $self->trim_whitespaces;
 194
 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
 199             # Set default values if not set
 200             $self->sms_provider_id(undef) unless $self->sms_provider_id;
 201             $self->guarantorid(undef)     unless $self->guarantorid;
 202
 203             unless ( $self->in_storage ) {    #AddMember
 204
 205                 # Generate a valid userid/login if needed
 206                 $self->generate_userid
 207                   if not $self->userid or not $self->has_valid_userid;
 208
 209                 # Add expiration date if it isn't already there
 210                 unless ( $self->dateexpiry ) {
 211                     $self->dateexpiry( $self->category->get_expiry_date );
 212                 }
 213
 214                 # Add enrollment date if it isn't already there
 215                 unless ( $self->dateenrolled ) {
 216                     $self->dateenrolled(dt_from_string);
 217                 }
 218
 219                 # Set the privacy depending on the patron's category
 220                 my $default_privacy = $self->category->default_privacy || q{};
 221                 $default_privacy =
 222                     $default_privacy eq 'default' ? 1
 223                   : $default_privacy eq 'never'   ? 2
 224                   : $default_privacy eq 'forever' ? 0
 225                   :                                                   undef;
 226                 $self->privacy($default_privacy);
 227
 228                 unless ( defined $self->privacy_guarantor_checkouts ) {
 229                     $self->privacy_guarantor_checkouts(0);
 230                 }
 231
 232                 # Make a copy of the plain text password for later use
 233                 $self->plain_text_password( $self->password );
 234
 235                 # Create a disabled account if no password provided
 236                 $self->password( $self->password
 237                     ? Koha::AuthUtils::hash_password( $self->password )
 238                     : '!' );
 239
 240                 $self->borrowernumber(undef);
 241
 242                 $self = $self->SUPER::store;
 243
 244                 $self->add_enrolment_fee_if_needed;
 245
 246                 logaction( "MEMBERS", "CREATE", $self->borrowernumber, "" )
 247                   if C4::Context->preference("BorrowersLog");
 248             }
 249             else {    #ModMember
 250
 251                 # Come from ModMember, but should not be possible (?)
 252                 $self->dateenrolled(undef) unless $self->dateenrolled;
 253                 $self->dateexpiry(undef)   unless $self->dateexpiry;
 254
 255
 256                 my $self_from_storage = $self->get_from_storage;
 257                 # FIXME We should not deal with that here, callers have to do this job
 258                 # Moved from ModMember to prevent regressions
 259                 unless ( $self->userid ) {
 260                     my $stored_userid = $self_from_storage->userid;
 261                     $self->userid($stored_userid);
 262                 }
 263
 264                 # Password must be updated using $self->update_password
 265                 $self->password($self_from_storage->password);
 266
 267                 if ( C4::Context->preference('FeeOnChangePatronCategory')
 268                     and $self->category->categorycode ne
 269                     $self_from_storage->category->categorycode )
 270                 {
 271                     $self->add_enrolment_fee_if_needed;
 272                 }
 273
 274                 my $borrowers_log = C4::Context->preference("BorrowersLog");
 275                 my $previous_cardnumber = $self_from_storage->cardnumber;
 276                 if ($borrowers_log
 277                     && ( !defined $previous_cardnumber
 278                         || $previous_cardnumber ne $self->cardnumber )
 279                     )
 280                 {
 281                     logaction(
 282                         "MEMBERS",
 283                         "MODIFY",
 284                         $self->borrowernumber,
 285                         to_json(
 286                             {
 287                                 cardnumber_replaced => {
 288                                     previous_cardnumber => $previous_cardnumber,
 289                                     new_cardnumber      => $self->cardnumber,
 290                                 }
 291                             },
 292                             { utf8 => 1, pretty => 1 }
 293                         )
 294                     );
 295                 }
 296
 297                 logaction( "MEMBERS", "MODIFY", $self->borrowernumber,
 298                     "UPDATE (executed w/ arg: " . $self->borrowernumber . ")" )
 299                   if $borrowers_log;
 300
 301                 $self = $self->SUPER::store;
 302             }
 303         }
 304     );
 305     return $self;
 306 }
 307
 308 =head3 delete
 309
 310 $patron->delete
 311
 312 Delete patron's holds, lists and finally the patron.
 313
 314 Lists owned by the borrower are deleted, but entries from the borrower to
 315 other lists are kept.
 316
 317 =cut
 318
 319 sub delete {
 320     my ($self) = @_;
 321
 322     my $deleted;
 323     $self->_result->result_source->schema->txn_do(
 324         sub {
 325             # Delete Patron's holds
 326             $self->holds->delete;
 327
 328             # Delete all lists and all shares of this borrower
 329             # Consistent with the approach Koha uses on deleting individual lists
 330             # Note that entries in virtualshelfcontents added by this borrower to
 331             # lists of others will be handled by a table constraint: the borrower
 332             # is set to NULL in those entries.
 333             # NOTE:
 334             # We could handle the above deletes via a constraint too.
 335             # But a new BZ report 11889 has been opened to discuss another approach.
 336             # Instead of deleting we could also disown lists (based on a pref).
 337             # In that way we could save shared and public lists.
 338             # The current table constraints support that idea now.
 339             # This pref should then govern the results of other routines/methods such as
 340             # Koha::Virtualshelf->new->delete too.
 341             # FIXME Could be $patron->get_lists
 342             $_->delete for Koha::Virtualshelves->search( { owner => $self->borrowernumber } );
 343
 344             $deleted = $self->SUPER::delete;
 345
 346             logaction( "MEMBERS", "DELETE", $self->borrowernumber, "" ) if C4::Context->preference("BorrowersLog");
 347         }
 348     );
 349     return $deleted;
 350 }
 351
 352
 353 =head3 category
 354
 355 my $patron_category = $patron->category
 356
 357 Return the patron category for this patron
 358
 359 =cut
 360
 361 sub category {
 362     my ( $self ) = @_;
 363     return Koha::Patron::Category->_new_from_dbic( $self->_result->categorycode );
 364 }
 365
 366 =head3 guarantor
 367
 368 Returns a Koha::Patron object for this patron's guarantor
 369
 370 =cut
 371
 372 sub guarantor {
 373     my ( $self ) = @_;
 374
 375     return unless $self->guarantorid();
 376
 377     return Koha::Patrons->find( $self->guarantorid() );
 378 }
 379
 380 sub image {
 381     my ( $self ) = @_;
 382
 383     return scalar Koha::Patron::Images->find( $self->borrowernumber );
 384 }
 385
 386 sub library {
 387     my ( $self ) = @_;
 388     return Koha::Library->_new_from_dbic($self->_result->branchcode);
 389 }
 390
 391 =head3 guarantees
 392
 393 Returns the guarantees (list of Koha::Patron) of this patron
 394
 395 =cut
 396
 397 sub guarantees {
 398     my ( $self ) = @_;
 399
 400     return Koha::Patrons->search( { guarantorid => $self->borrowernumber }, { order_by => { -asc => ['surname','firstname'] } } );
 401 }
 402
 403 =head3 housebound_profile
 404
 405 Returns the HouseboundProfile associated with this patron.
 406
 407 =cut
 408
 409 sub housebound_profile {
 410     my ( $self ) = @_;
 411     my $profile = $self->_result->housebound_profile;
 412     return Koha::Patron::HouseboundProfile->_new_from_dbic($profile)
 413         if ( $profile );
 414     return;
 415 }
 416
 417 =head3 housebound_role
 418
 419 Returns the HouseboundRole associated with this patron.
 420
 421 =cut
 422
 423 sub housebound_role {
 424     my ( $self ) = @_;
 425
 426     my $role = $self->_result->housebound_role;
 427     return Koha::Patron::HouseboundRole->_new_from_dbic($role) if ( $role );
 428     return;
 429 }
 430
 431 =head3 siblings
 432
 433 Returns the siblings of this patron.
 434
 435 =cut
 436
 437 sub siblings {
 438     my ( $self ) = @_;
 439
 440     my $guarantor = $self->guarantor;
 441
 442     return unless $guarantor;
 443
 444     return Koha::Patrons->search(
 445         {
 446             guarantorid => {
 447                 '!=' => undef,
 448                 '=' => $guarantor->id,
 449             },
 450             borrowernumber => {
 451                 '!=' => $self->borrowernumber,
 452             }
 453         }
 454     );
 455 }
 456
 457 =head3 merge_with
 458
 459     my $patron = Koha::Patrons->find($id);
 460     $patron->merge_with( \@patron_ids );
 461
 462     This subroutine merges a list of patrons into the patron record. This is accomplished by finding
 463     all related patron ids for the patrons to be merged in other tables and changing the ids to be that
 464     of the keeper patron.
 465
 466 =cut
 467
 468 sub merge_with {
 469     my ( $self, $patron_ids ) = @_;
 470
 471     my @patron_ids = @{ $patron_ids };
 472
 473     # Ensure the keeper isn't in the list of patrons to merge
 474     @patron_ids = grep { $_ ne $self->id } @patron_ids;
 475
 476     my $schema = Koha::Database->new()->schema();
 477
 478     my $results;
 479
 480     $self->_result->result_source->schema->txn_do( sub {
 481         foreach my $patron_id (@patron_ids) {
 482             my $patron = Koha::Patrons->find( $patron_id );
 483
 484             next unless $patron;
 485
 486             # Unbless for safety, the patron will end up being deleted
 487             $results->{merged}->{$patron_id}->{patron} = $patron->unblessed;
 488
 489             while (my ($r, $field) = each(%$RESULTSET_PATRON_ID_MAPPING)) {
 490                 my $rs = $schema->resultset($r)->search({ $field => $patron_id });
 491                 $results->{merged}->{ $patron_id }->{updated}->{$r} = $rs->count();
 492                 $rs->update({ $field => $self->id });
 493             }
 494
 495             $patron->move_to_deleted();
 496             $patron->delete();
 497         }
 498     });
 499
 500     return $results;
 501 }
 502
 503
 504
 505 =head3 wants_check_for_previous_checkout
 506
 507     $wants_check = $patron->wants_check_for_previous_checkout;
 508
 509 Return 1 if Koha needs to perform PrevIssue checking, else 0.
 510
 511 =cut
 512
 513 sub wants_check_for_previous_checkout {
 514     my ( $self ) = @_;
 515     my $syspref = C4::Context->preference("checkPrevCheckout");
 516
 517     # Simple cases
 518     ## Hard syspref trumps all
 519     return 1 if ($syspref eq 'hardyes');
 520     return 0 if ($syspref eq 'hardno');
 521     ## Now, patron pref trumps all
 522     return 1 if ($self->checkprevcheckout eq 'yes');
 523     return 0 if ($self->checkprevcheckout eq 'no');
 524
 525     # More complex: patron inherits -> determine category preference
 526     my $checkPrevCheckoutByCat = $self->category->checkprevcheckout;
 527     return 1 if ($checkPrevCheckoutByCat eq 'yes');
 528     return 0 if ($checkPrevCheckoutByCat eq 'no');
 529
 530     # Finally: category preference is inherit, default to 0
 531     if ($syspref eq 'softyes') {
 532         return 1;
 533     } else {
 534         return 0;
 535     }
 536 }
 537
 538 =head3 do_check_for_previous_checkout
 539
 540     $do_check = $patron->do_check_for_previous_checkout($item);
 541
 542 Return 1 if the bib associated with $ITEM has previously been checked out to
 543 $PATRON, 0 otherwise.
 544
 545 =cut
 546
 547 sub do_check_for_previous_checkout {
 548     my ( $self, $item ) = @_;
 549
 550     # Find all items for bib and extract item numbers.
 551     my @items = Koha::Items->search({biblionumber => $item->{biblionumber}});
 552     my @item_nos;
 553     foreach my $item (@items) {
 554         push @item_nos, $item->itemnumber;
 555     }
 556
 557     # Create (old)issues search criteria
 558     my $criteria = {
 559         borrowernumber => $self->borrowernumber,
 560         itemnumber => \@item_nos,
 561     };
 562
 563     # Check current issues table
 564     my $issues = Koha::Checkouts->search($criteria);
 565     return 1 if $issues->count; # 0 || N
 566
 567     # Check old issues table
 568     my $old_issues = Koha::Old::Checkouts->search($criteria);
 569     return $old_issues->count;  # 0 || N
 570 }
 571
 572 =head3 is_debarred
 573
 574 my $debarment_expiration = $patron->is_debarred;
 575
 576 Returns the date a patron debarment will expire, or undef if the patron is not
 577 debarred
 578
 579 =cut
 580
 581 sub is_debarred {
 582     my ($self) = @_;
 583
 584     return unless $self->debarred;
 585     return $self->debarred
 586       if $self->debarred =~ '^9999'
 587       or dt_from_string( $self->debarred ) > dt_from_string;
 588     return;
 589 }
 590
 591 =head3 is_expired
 592
 593 my $is_expired = $patron->is_expired;
 594
 595 Returns 1 if the patron is expired or 0;
 596
 597 =cut
 598
 599 sub is_expired {
 600     my ($self) = @_;
 601     return 0 unless $self->dateexpiry;
 602     return 0 if $self->dateexpiry =~ '^9999';
 603     return 1 if dt_from_string( $self->dateexpiry ) < dt_from_string->truncate( to => 'day' );
 604     return 0;
 605 }
 606
 607 =head3 is_going_to_expire
 608
 609 my $is_going_to_expire = $patron->is_going_to_expire;
 610
 611 Returns 1 if the patron is going to expired, depending on the NotifyBorrowerDeparture pref or 0
 612
 613 =cut
 614
 615 sub is_going_to_expire {
 616     my ($self) = @_;
 617
 618     my $delay = C4::Context->preference('NotifyBorrowerDeparture') || 0;
 619
 620     return 0 unless $delay;
 621     return 0 unless $self->dateexpiry;
 622     return 0 if $self->dateexpiry =~ '^9999';
 623     return 1 if dt_from_string( $self->dateexpiry )->subtract( days => $delay ) < dt_from_string->truncate( to => 'day' );
 624     return 0;
 625 }
 626
 627 =head3 update_password
 628
 629 my $updated = $patron->update_password( $userid, $password );
 630
 631 Update the userid and the password of a patron.
 632 If the userid already exists, returns and let DBIx::Class warns
 633 This will add an entry to action_logs if BorrowersLog is set.
 634
 635 =cut
 636
 637 sub update_password {
 638     my ( $self, $userid, $password ) = @_;
 639     eval { $self->userid($userid)->store; };
 640     return if $@; # Make sure the userid is not already in used by another patron
 641
 642     return 0 if $password eq '****' or $password eq '';
 643
 644     my $digest = Koha::AuthUtils::hash_password($password);
 645     $self->update(
 646         {
 647             password       => $digest,
 648             login_attempts => 0,
 649         }
 650     );
 651
 652     logaction( "MEMBERS", "CHANGE PASS", $self->borrowernumber, "" ) if C4::Context->preference("BorrowersLog");
 653     return $digest;
 654 }
 655
 656 =head3 set_password
 657
 658     $patron->set_password( $plain_text_password );
 659
 660 Set the patron's password.
 661
 662 =head4 Exceptions
 663
 664 The passed string is validated against the current password enforcement policy.
 665 Exceptions are thrown if the password is not good enough.
 666
 667 =over 4
 668
 669 =item Koha::Exceptions::Password::TooShort
 670
 671 =item Koha::Exceptions::Password::WhitespaceCharacters
 672
 673 =item Koha::Exceptions::Password::TooWeak
 674
 675 =back
 676
 677 =cut
 678
 679 sub set_password {
 680     my ( $self, $password ) = @_;
 681
 682     my ( $is_valid, $error ) = Koha::AuthUtils::is_password_valid( $password );
 683
 684     if ( !$is_valid ) {
 685         if ( $error eq 'too_short' ) {
 686             my $min_length = C4::Context->preference('minPasswordLength');
 687             $min_length = 3 if not $min_length or $min_length < 3;
 688
 689             my $password_length = length($password);
 690             Koha::Exceptions::Password::TooShort->throw(
 691                 { length => $password_length, min_length => $min_length } );
 692         }
 693         elsif ( $error eq 'has_whitespaces' ) {
 694             Koha::Exceptions::Password::WhitespaceCharacters->throw();
 695         }
 696         elsif ( $error eq 'too_weak' ) {
 697             Koha::Exceptions::Password::TooWeak->throw();
 698         }
 699     }
 700
 701     my $digest = Koha::AuthUtils::hash_password($password);
 702     $self->update(
 703         {   password       => $digest,
 704             login_attempts => 0,
 705         }
 706     );
 707
 708     logaction( "MEMBERS", "CHANGE PASS", $self->borrowernumber, "" )
 709         if C4::Context->preference("BorrowersLog");
 710
 711     return $self;
 712 }
 713
 714
 715 =head3 renew_account
 716
 717 my $new_expiry_date = $patron->renew_account
 718
 719 Extending the subscription to the expiry date.
 720
 721 =cut
 722
 723 sub renew_account {
 724     my ($self) = @_;
 725     my $date;
 726     if ( C4::Context->preference('BorrowerRenewalPeriodBase') eq 'combination' ) {
 727         $date = ( dt_from_string gt dt_from_string( $self->dateexpiry ) ) ? dt_from_string : dt_from_string( $self->dateexpiry );
 728     } else {
 729         $date =
 730             C4::Context->preference('BorrowerRenewalPeriodBase') eq 'dateexpiry'
 731             ? dt_from_string( $self->dateexpiry )
 732             : dt_from_string;
 733     }
 734     my $expiry_date = $self->category->get_expiry_date($date);
 735
 736     $self->dateexpiry($expiry_date);
 737     $self->date_renewed( dt_from_string() );
 738     $self->store();
 739
 740     $self->add_enrolment_fee_if_needed;
 741
 742     logaction( "MEMBERS", "RENEW", $self->borrowernumber, "Membership renewed" ) if C4::Context->preference("BorrowersLog");
 743     return dt_from_string( $expiry_date )->truncate( to => 'day' );
 744 }
 745
 746 =head3 has_overdues
 747
 748 my $has_overdues = $patron->has_overdues;
 749
 750 Returns the number of patron's overdues
 751
 752 =cut
 753
 754 sub has_overdues {
 755     my ($self) = @_;
 756     my $dtf = Koha::Database->new->schema->storage->datetime_parser;
 757     return $self->_result->issues->search({ date_due => { '<' => $dtf->format_datetime( dt_from_string() ) } })->count;
 758 }
 759
 760 =head3 track_login
 761
 762     $patron->track_login;
 763     $patron->track_login({ force => 1 });
 764
 765     Tracks a (successful) login attempt.
 766     The preference TrackLastPatronActivity must be enabled. Or you
 767     should pass the force parameter.
 768
 769 =cut
 770
 771 sub track_login {
 772     my ( $self, $params ) = @_;
 773     return if
 774         !$params->{force} &&
 775         !C4::Context->preference('TrackLastPatronActivity');
 776     $self->lastseen( dt_from_string() )->store;
 777 }
 778
 779 =head3 move_to_deleted
 780
 781 my $is_moved = $patron->move_to_deleted;
 782
 783 Move a patron to the deletedborrowers table.
 784 This can be done before deleting a patron, to make sure the data are not completely deleted.
 785
 786 =cut
 787
 788 sub move_to_deleted {
 789     my ($self) = @_;
 790     my $patron_infos = $self->unblessed;
 791     delete $patron_infos->{updated_on}; #This ensures the updated_on date in deletedborrowers will be set to the current timestamp
 792     return Koha::Database->new->schema->resultset('Deletedborrower')->create($patron_infos);
 793 }
 794
 795 =head3 article_requests
 796
 797 my @requests = $borrower->article_requests();
 798 my $requests = $borrower->article_requests();
 799
 800 Returns either a list of ArticleRequests objects,
 801 or an ArtitleRequests object, depending on the
 802 calling context.
 803
 804 =cut
 805
 806 sub article_requests {
 807     my ( $self ) = @_;
 808
 809     $self->{_article_requests} ||= Koha::ArticleRequests->search({ borrowernumber => $self->borrowernumber() });
 810
 811     return $self->{_article_requests};
 812 }
 813
 814 =head3 article_requests_current
 815
 816 my @requests = $patron->article_requests_current
 817
 818 Returns the article requests associated with this patron that are incomplete
 819
 820 =cut
 821
 822 sub article_requests_current {
 823     my ( $self ) = @_;
 824
 825     $self->{_article_requests_current} ||= Koha::ArticleRequests->search(
 826         {
 827             borrowernumber => $self->id(),
 828             -or          => [
 829                 { status => Koha::ArticleRequest::Status::Pending },
 830                 { status => Koha::ArticleRequest::Status::Processing }
 831             ]
 832         }
 833     );
 834
 835     return $self->{_article_requests_current};
 836 }
 837
 838 =head3 article_requests_finished
 839
 840 my @requests = $biblio->article_requests_finished
 841
 842 Returns the article requests associated with this patron that are completed
 843
 844 =cut
 845
 846 sub article_requests_finished {
 847     my ( $self, $borrower ) = @_;
 848
 849     $self->{_article_requests_finished} ||= Koha::ArticleRequests->search(
 850         {
 851             borrowernumber => $self->id(),
 852             -or          => [
 853                 { status => Koha::ArticleRequest::Status::Completed },
 854                 { status => Koha::ArticleRequest::Status::Canceled }
 855             ]
 856         }
 857     );
 858
 859     return $self->{_article_requests_finished};
 860 }
 861
 862 =head3 add_enrolment_fee_if_needed
 863
 864 my $enrolment_fee = $patron->add_enrolment_fee_if_needed;
 865
 866 Add enrolment fee for a patron if needed.
 867
 868 =cut
 869
 870 sub add_enrolment_fee_if_needed {
 871     my ($self) = @_;
 872     my $enrolment_fee = $self->category->enrolmentfee;
 873     if ( $enrolment_fee && $enrolment_fee > 0 ) {
 874         # insert fee in patron debts
 875         C4::Accounts::manualinvoice( $self->borrowernumber, '', '', 'A', $enrolment_fee );
 876     }
 877     return $enrolment_fee || 0;
 878 }
 879
 880 =head3 checkouts
 881
 882 my $checkouts = $patron->checkouts
 883
 884 =cut
 885
 886 sub checkouts {
 887     my ($self) = @_;
 888     my $checkouts = $self->_result->issues;
 889     return Koha::Checkouts->_new_from_dbic( $checkouts );
 890 }
 891
 892 =head3 pending_checkouts
 893
 894 my $pending_checkouts = $patron->pending_checkouts
 895
 896 This method will return the same as $self->checkouts, but with a prefetch on
 897 items, biblio and biblioitems.
 898
 899 It has been introduced to replaced the C4::Members::GetPendingIssues subroutine
 900
 901 It should not be used directly, prefer to access fields you need instead of
 902 retrieving all these fields in one go.
 903
 904
 905 =cut
 906
 907 sub pending_checkouts {
 908     my( $self ) = @_;
 909     my $checkouts = $self->_result->issues->search(
 910         {},
 911         {
 912             order_by => [
 913                 { -desc => 'me.timestamp' },
 914                 { -desc => 'issuedate' },
 915                 { -desc => 'issue_id' }, # Sort by issue_id should be enough
 916             ],
 917             prefetch => { item => { biblio => 'biblioitems' } },
 918         }
 919     );
 920     return Koha::Checkouts->_new_from_dbic( $checkouts );
 921 }
 922
 923 =head3 old_checkouts
 924
 925 my $old_checkouts = $patron->old_checkouts
 926
 927 =cut
 928
 929 sub old_checkouts {
 930     my ($self) = @_;
 931     my $old_checkouts = $self->_result->old_issues;
 932     return Koha::Old::Checkouts->_new_from_dbic( $old_checkouts );
 933 }
 934
 935 =head3 get_overdues
 936
 937 my $overdue_items = $patron->get_overdues
 938
 939 Return the overdue items
 940
 941 =cut
 942
 943 sub get_overdues {
 944     my ($self) = @_;
 945     my $dtf = Koha::Database->new->schema->storage->datetime_parser;
 946     return $self->checkouts->search(
 947         {
 948             'me.date_due' => { '<' => $dtf->format_datetime(dt_from_string) },
 949         },
 950         {
 951             prefetch => { item => { biblio => 'biblioitems' } },
 952         }
 953     );
 954 }
 955
 956 =head3 get_routing_lists
 957
 958 my @routinglists = $patron->get_routing_lists
 959
 960 Returns the routing lists a patron is subscribed to.
 961
 962 =cut
 963
 964 sub get_routing_lists {
 965     my ($self) = @_;
 966     my $routing_list_rs = $self->_result->subscriptionroutinglists;
 967     return Koha::Subscription::Routinglists->_new_from_dbic($routing_list_rs);
 968 }
 969
 970 =head3 get_age
 971
 972 my $age = $patron->get_age
 973
 974 Return the age of the patron
 975
 976 =cut
 977
 978 sub get_age {
 979     my ($self)    = @_;
 980     my $today_str = dt_from_string->strftime("%Y-%m-%d");
 981     return unless $self->dateofbirth;
 982     my $dob_str   = dt_from_string( $self->dateofbirth )->strftime("%Y-%m-%d");
 983
 984     my ( $dob_y,   $dob_m,   $dob_d )   = split /-/, $dob_str;
 985     my ( $today_y, $today_m, $today_d ) = split /-/, $today_str;
 986
 987     my $age = $today_y - $dob_y;
 988     if ( $dob_m . $dob_d > $today_m . $today_d ) {
 989         $age--;
 990     }
 991
 992     return $age;
 993 }
 994
 995 =head3 account
 996
 997 my $account = $patron->account
 998
 999 =cut
1000
1001 sub account {
1002     my ($self) = @_;
1003     return Koha::Account->new( { patron_id => $self->borrowernumber } );
1004 }
1005
1006 =head3 holds
1007
1008 my $holds = $patron->holds
1009
1010 Return all the holds placed by this patron
1011
1012 =cut
1013
1014 sub holds {
1015     my ($self) = @_;
1016     my $holds_rs = $self->_result->reserves->search( {}, { order_by => 'reservedate' } );
1017     return Koha::Holds->_new_from_dbic($holds_rs);
1018 }
1019
1020 =head3 old_holds
1021
1022 my $old_holds = $patron->old_holds
1023
1024 Return all the historical holds for this patron
1025
1026 =cut
1027
1028 sub old_holds {
1029     my ($self) = @_;
1030     my $old_holds_rs = $self->_result->old_reserves->search( {}, { order_by => 'reservedate' } );
1031     return Koha::Old::Holds->_new_from_dbic($old_holds_rs);
1032 }
1033
1034 =head3 notice_email_address
1035
1036   my $email = $patron->notice_email_address;
1037
1038 Return the email address of patron used for notices.
1039 Returns the empty string if no email address.
1040
1041 =cut
1042
1043 sub notice_email_address{
1044     my ( $self ) = @_;
1045
1046     my $which_address = C4::Context->preference("AutoEmailPrimaryAddress");
1047     # if syspref is set to 'first valid' (value == OFF), look up email address
1048     if ( $which_address eq 'OFF' ) {
1049         return $self->first_valid_email_address;
1050     }
1051
1052     return $self->$which_address || '';
1053 }
1054
1055 =head3 first_valid_email_address
1056
1057 my $first_valid_email_address = $patron->first_valid_email_address
1058
1059 Return the first valid email address for a patron.
1060 For now, the order  is defined as email, emailpro, B_email.
1061 Returns the empty string if the borrower has no email addresses.
1062
1063 =cut
1064
1065 sub first_valid_email_address {
1066     my ($self) = @_;
1067
1068     return $self->email() || $self->emailpro() || $self->B_email() || q{};
1069 }
1070
1071 =head3 get_club_enrollments
1072
1073 =cut
1074
1075 sub get_club_enrollments {
1076     my ( $self, $return_scalar ) = @_;
1077
1078     my $e = Koha::Club::Enrollments->search( { borrowernumber => $self->borrowernumber(), date_canceled => undef } );
1079
1080     return $e if $return_scalar;
1081
1082     return wantarray ? $e->as_list : $e;
1083 }
1084
1085 =head3 get_enrollable_clubs
1086
1087 =cut
1088
1089 sub get_enrollable_clubs {
1090     my ( $self, $is_enrollable_from_opac, $return_scalar ) = @_;
1091
1092     my $params;
1093     $params->{is_enrollable_from_opac} = $is_enrollable_from_opac
1094       if $is_enrollable_from_opac;
1095     $params->{is_email_required} = 0 unless $self->first_valid_email_address();
1096
1097     $params->{borrower} = $self;
1098
1099     my $e = Koha::Clubs->get_enrollable($params);
1100
1101     return $e if $return_scalar;
1102
1103     return wantarray ? $e->as_list : $e;
1104 }
1105
1106 =head3 account_locked
1107
1108 my $is_locked = $patron->account_locked
1109
1110 Return true if the patron has reach the maximum number of login attempts (see pref FailedLoginAttempts).
1111 Otherwise return false.
1112 If the pref is not set (empty string, null or 0), the feature is considered as disabled.
1113
1114 =cut
1115
1116 sub account_locked {
1117     my ($self) = @_;
1118     my $FailedLoginAttempts = C4::Context->preference('FailedLoginAttempts');
1119     return ( $FailedLoginAttempts
1120           and $self->login_attempts
1121           and $self->login_attempts >= $FailedLoginAttempts )? 1 : 0;
1122 }
1123
1124 =head3 can_see_patron_infos
1125
1126 my $can_see = $patron->can_see_patron_infos( $patron );
1127
1128 Return true if the patron (usually the logged in user) can see the patron's infos for a given patron
1129
1130 =cut
1131
1132 sub can_see_patron_infos {
1133     my ( $self, $patron ) = @_;
1134     return $self->can_see_patrons_from( $patron->library->branchcode );
1135 }
1136
1137 =head3 can_see_patrons_from
1138
1139 my $can_see = $patron->can_see_patrons_from( $branchcode );
1140
1141 Return true if the patron (usually the logged in user) can see the patron's infos from a given library
1142
1143 =cut
1144
1145 sub can_see_patrons_from {
1146     my ( $self, $branchcode ) = @_;
1147     my $can = 0;
1148     if ( $self->branchcode eq $branchcode ) {
1149         $can = 1;
1150     } elsif ( $self->has_permission( { borrowers => 'view_borrower_infos_from_any_libraries' } ) ) {
1151         $can = 1;
1152     } elsif ( my $library_groups = $self->library->library_groups ) {
1153         while ( my $library_group = $library_groups->next ) {
1154             if ( $library_group->parent->has_child( $branchcode ) ) {
1155                 $can = 1;
1156                 last;
1157             }
1158         }
1159     }
1160     return $can;
1161 }
1162
1163 =head3 libraries_where_can_see_patrons
1164
1165 my $libraries = $patron-libraries_where_can_see_patrons;
1166
1167 Return the list of branchcodes(!) of libraries the patron is allowed to see other patron's infos.
1168 The branchcodes are arbitrarily returned sorted.
1169 We are supposing here that the object is related to the logged in patron (use of C4::Context::only_my_library)
1170
1171 An empty array means no restriction, the patron can see patron's infos from any libraries.
1172
1173 =cut
1174
1175 sub libraries_where_can_see_patrons {
1176     my ( $self ) = @_;
1177     my $userenv = C4::Context->userenv;
1178
1179     return () unless $userenv; # For tests, but userenv should be defined in tests...
1180
1181     my @restricted_branchcodes;
1182     if (C4::Context::only_my_library) {
1183         push @restricted_branchcodes, $self->branchcode;
1184     }
1185     else {
1186         unless (
1187             $self->has_permission(
1188                 { borrowers => 'view_borrower_infos_from_any_libraries' }
1189             )
1190           )
1191         {
1192             my $library_groups = $self->library->library_groups({ ft_hide_patron_info => 1 });
1193             if ( $library_groups->count )
1194             {
1195                 while ( my $library_group = $library_groups->next ) {
1196                     my $parent = $library_group->parent;
1197                     if ( $parent->has_child( $self->branchcode ) ) {
1198                         push @restricted_branchcodes, $parent->children->get_column('branchcode');
1199                     }
1200                 }
1201             }
1202
1203             @restricted_branchcodes = ( $self->branchcode ) unless @restricted_branchcodes;
1204         }
1205     }
1206
1207     @restricted_branchcodes = grep { defined $_ } @restricted_branchcodes;
1208     @restricted_branchcodes = uniq(@restricted_branchcodes);
1209     @restricted_branchcodes = sort(@restricted_branchcodes);
1210     return @restricted_branchcodes;
1211 }
1212
1213 sub has_permission {
1214     my ( $self, $flagsrequired ) = @_;
1215     return unless $self->userid;
1216     # TODO code from haspermission needs to be moved here!
1217     return C4::Auth::haspermission( $self->userid, $flagsrequired );
1218 }
1219
1220 =head3 is_adult
1221
1222 my $is_adult = $patron->is_adult
1223
1224 Return true if the patron has a category with a type Adult (A) or Organization (I)
1225
1226 =cut
1227
1228 sub is_adult {
1229     my ( $self ) = @_;
1230     return $self->category->category_type =~ /^(A|I)$/ ? 1 : 0;
1231 }
1232
1233 =head3 is_child
1234
1235 my $is_child = $patron->is_child
1236
1237 Return true if the patron has a category with a type Child (C)
1238
1239 =cut
1240 sub is_child {
1241     my( $self ) = @_;
1242     return $self->category->category_type eq 'C' ? 1 : 0;
1243 }
1244
1245 =head3 has_valid_userid
1246
1247 my $patron = Koha::Patrons->find(42);
1248 $patron->userid( $new_userid );
1249 my $has_a_valid_userid = $patron->has_valid_userid
1250
1251 my $patron = Koha::Patron->new( $params );
1252 my $has_a_valid_userid = $patron->has_valid_userid
1253
1254 Return true if the current userid of this patron is valid/unique, otherwise false.
1255
1256 Note that this should be done in $self->store instead and raise an exception if needed.
1257
1258 =cut
1259
1260 sub has_valid_userid {
1261     my ($self) = @_;
1262
1263     return 0 unless $self->userid;
1264
1265     return 0 if ( $self->userid eq C4::Context->config('user') );    # DB user
1266
1267     my $already_exists = Koha::Patrons->search(
1268         {
1269             userid => $self->userid,
1270             (
1271                 $self->in_storage
1272                 ? ( borrowernumber => { '!=' => $self->borrowernumber } )
1273                 : ()
1274             ),
1275         }
1276     )->count;
1277     return $already_exists ? 0 : 1;
1278 }
1279
1280 =head3 generate_userid
1281
1282 my $patron = Koha::Patron->new( $params );
1283 $patron->generate_userid
1284
1285 Generate a userid using the $surname and the $firstname (if there is a value in $firstname).
1286
1287 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).
1288
1289 =cut
1290
1291 sub generate_userid {
1292     my ($self) = @_;
1293     my $offset = 0;
1294     my $firstname = $self->firstname // q{};
1295     my $surname = $self->surname // q{};
1296     #The script will "do" the following code and increment the $offset until the generated userid is unique
1297     do {
1298       $firstname =~ s/[[:digit:][:space:][:blank:][:punct:][:cntrl:]]//g;
1299       $surname =~ s/[[:digit:][:space:][:blank:][:punct:][:cntrl:]]//g;
1300       my $userid = lc(($firstname)? "$firstname.$surname" : $surname);
1301       $userid = unac_string('utf-8',$userid);
1302       $userid .= $offset unless $offset == 0;
1303       $self->userid( $userid );
1304       $offset++;
1305      } while (! $self->has_valid_userid );
1306
1307      return $self;
1308
1309 }
1310
1311 =head2 Internal methods
1312
1313 =head3 _type
1314
1315 =cut
1316
1317 sub _type {
1318     return 'Borrower';
1319 }
1320
1321 =head1 AUTHOR
1322
1323 Kyle M Hall <kyle@bywatersolutions.com>
1324 Alex Sassmannshausen <alex.sassmannshausen@ptfs-europe.com>
1325
1326 =cut
1327
1328 1;