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