C4/Members.pm

   1 package C4::Members;
   2
   3 # Copyright 2000-2003 Katipo Communications
   4 # Copyright 2010 BibLibre
   5 # Parts Copyright 2010 Catalyst IT
   6 #
   7 # This file is part of Koha.
   8 #
   9 # Koha is free software; you can redistribute it and/or modify it
  10 # under the terms of the GNU General Public License as published by
  11 # the Free Software Foundation; either version 3 of the License, or
  12 # (at your option) any later version.
  13 #
  14 # Koha is distributed in the hope that it will be useful, but
  15 # WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  17 # GNU General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU General Public License
  20 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  21
  22
  23 use strict;
  24 #use warnings; FIXME - Bug 2505
  25 use C4::Context;
  26 use String::Random qw( random_string );
  27 use Scalar::Util qw( looks_like_number );
  28 use Date::Calc qw/Today check_date Date_to_Days/;
  29 use List::MoreUtils qw( uniq );
  30 use C4::Log; # logaction
  31 use C4::Overdues;
  32 use C4::Reserves;
  33 use C4::Accounts;
  34 use C4::Biblio;
  35 use C4::Letters;
  36 use C4::Members::Attributes qw(SearchIdMatchingAttribute UpdateBorrowerAttribute);
  37 use C4::NewsChannels; #get slip news
  38 use DateTime;
  39 use Koha::Database;
  40 use Koha::DateUtils;
  41 use Text::Unaccent qw( unac_string );
  42 use Koha::AuthUtils qw(hash_password);
  43 use Koha::Database;
  44 use Koha::Holds;
  45 use Koha::List::Patron;
  46 use Koha::Patrons;
  47 use Koha::Patron::Categories;
  48 use Koha::Schema;
  49
  50 our (@ISA,@EXPORT,@EXPORT_OK,$debug);
  51
  52 use Module::Load::Conditional qw( can_load );
  53 if ( ! can_load( modules => { 'Koha::NorwegianPatronDB' => undef } ) ) {
  54    $debug && warn "Unable to load Koha::NorwegianPatronDB";
  55 }
  56
  57
  58 BEGIN {
  59     $debug = $ENV{DEBUG} || 0;
  60     require Exporter;
  61     @ISA = qw(Exporter);
  62     #Get data
  63     push @EXPORT, qw(
  64
  65         &GetPendingIssues
  66         &GetAllIssues
  67
  68         &GetBorrowersToExpunge
  69
  70         &IssueSlip
  71
  72         GetOverduesForPatron
  73     );
  74
  75     #Modify data
  76     push @EXPORT, qw(
  77         &ModMember
  78         &changepassword
  79     );
  80
  81     #Insert data
  82     push @EXPORT, qw(
  83         &AddMember
  84     &AddMember_Auto
  85         &AddMember_Opac
  86     );
  87
  88     #Check data
  89     push @EXPORT, qw(
  90         &checkuserpassword
  91         &Check_Userid
  92         &Generate_Userid
  93         &fixup_cardnumber
  94         &checkcardnumber
  95     );
  96 }
  97
  98 =head1 NAME
  99
 100 C4::Members - Perl Module containing convenience functions for member handling
 101
 102 =head1 SYNOPSIS
 103
 104 use C4::Members;
 105
 106 =head1 DESCRIPTION
 107
 108 This module contains routines for adding, modifying and deleting members/patrons/borrowers
 109
 110 =head1 FUNCTIONS
 111
 112 =head2 patronflags
 113
 114  $flags = &patronflags($patron);
 115
 116 This function is not exported.
 117
 118 The following will be set where applicable:
 119  $flags->{CHARGES}->{amount}        Amount of debt
 120  $flags->{CHARGES}->{noissues}      Set if debt amount >$5.00 (or syspref noissuescharge)
 121  $flags->{CHARGES}->{message}       Message -- deprecated
 122
 123  $flags->{CREDITS}->{amount}        Amount of credit
 124  $flags->{CREDITS}->{message}       Message -- deprecated
 125
 126  $flags->{  GNA  }                  Patron has no valid address
 127  $flags->{  GNA  }->{noissues}      Set for each GNA
 128  $flags->{  GNA  }->{message}       "Borrower has no valid address" -- deprecated
 129
 130  $flags->{ LOST  }                  Patron's card reported lost
 131  $flags->{ LOST  }->{noissues}      Set for each LOST
 132  $flags->{ LOST  }->{message}       Message -- deprecated
 133
 134  $flags->{DBARRED}                  Set if patron debarred, no access
 135  $flags->{DBARRED}->{noissues}      Set for each DBARRED
 136  $flags->{DBARRED}->{message}       Message -- deprecated
 137
 138  $flags->{ NOTES }
 139  $flags->{ NOTES }->{message}       The note itself.  NOT deprecated
 140
 141  $flags->{ ODUES }                  Set if patron has overdue books.
 142  $flags->{ ODUES }->{message}       "Yes"  -- deprecated
 143  $flags->{ ODUES }->{itemlist}      ref-to-array: list of overdue books
 144  $flags->{ ODUES }->{itemlisttext}  Text list of overdue items -- deprecated
 145
 146  $flags->{WAITING}                  Set if any of patron's reserves are available
 147  $flags->{WAITING}->{message}       Message -- deprecated
 148  $flags->{WAITING}->{itemlist}      ref-to-array: list of available items
 149
 150 =over
 151
 152 =item C<$flags-E<gt>{ODUES}-E<gt>{itemlist}> is a reference-to-array listing the
 153 overdue items. Its elements are references-to-hash, each describing an
 154 overdue item. The keys are selected fields from the issues, biblio,
 155 biblioitems, and items tables of the Koha database.
 156
 157 =item C<$flags-E<gt>{ODUES}-E<gt>{itemlisttext}> is a string giving a text listing of
 158 the overdue items, one per line.  Deprecated.
 159
 160 =item C<$flags-E<gt>{WAITING}-E<gt>{itemlist}> is a reference-to-array listing the
 161 available items. Each element is a reference-to-hash whose keys are
 162 fields from the reserves table of the Koha database.
 163
 164 =back
 165
 166 All the "message" fields that include language generated in this function are deprecated,
 167 because such strings belong properly in the display layer.
 168
 169 The "message" field that comes from the DB is OK.
 170
 171 =cut
 172
 173 # TODO: use {anonymous => hashes} instead of a dozen %flaginfo
 174 # FIXME rename this function.
 175 sub patronflags {
 176     my %flags;
 177     my ( $patroninformation) = @_;
 178     my $dbh=C4::Context->dbh;
 179     my $patron = Koha::Patrons->find( $patroninformation->{borrowernumber} );
 180     my $account = $patron->account;
 181     my $owing = $account->non_issues_charges;
 182     if ( $owing > 0 ) {
 183         my %flaginfo;
 184         my $noissuescharge = C4::Context->preference("noissuescharge") || 5;
 185         $flaginfo{'message'} = sprintf 'Patron owes %.02f', $owing;
 186         $flaginfo{'amount'}  = sprintf "%.02f", $owing;
 187         if ( $owing > $noissuescharge && !C4::Context->preference("AllowFineOverride") ) {
 188             $flaginfo{'noissues'} = 1;
 189         }
 190         $flags{'CHARGES'} = \%flaginfo;
 191     }
 192     elsif ( ( my $balance = $account->balance ) < 0 ) {
 193         my %flaginfo;
 194         $flaginfo{'message'} = sprintf 'Patron has credit of %.02f', -$balance;
 195         $flaginfo{'amount'}  = sprintf "%.02f", $balance;
 196         $flags{'CREDITS'} = \%flaginfo;
 197     }
 198
 199     # Check the debt of the guarntees of this patron
 200     my $no_issues_charge_guarantees = C4::Context->preference("NoIssuesChargeGuarantees");
 201     $no_issues_charge_guarantees = undef unless looks_like_number( $no_issues_charge_guarantees );
 202     if ( defined $no_issues_charge_guarantees ) {
 203         my $p = Koha::Patrons->find( $patroninformation->{borrowernumber} );
 204         my @guarantees = $p->guarantees();
 205         my $guarantees_non_issues_charges;
 206         foreach my $g ( @guarantees ) {
 207             $guarantees_non_issues_charges += $g->account->non_issues_charges;
 208         }
 209
 210         if ( $guarantees_non_issues_charges > $no_issues_charge_guarantees ) {
 211             my %flaginfo;
 212             $flaginfo{'message'} = sprintf 'patron guarantees owe %.02f', $guarantees_non_issues_charges;
 213             $flaginfo{'amount'}  = $guarantees_non_issues_charges;
 214             $flaginfo{'noissues'} = 1 unless C4::Context->preference("allowfineoverride");
 215             $flags{'CHARGES_GUARANTEES'} = \%flaginfo;
 216         }
 217     }
 218
 219     if (   $patroninformation->{'gonenoaddress'}
 220         && $patroninformation->{'gonenoaddress'} == 1 )
 221     {
 222         my %flaginfo;
 223         $flaginfo{'message'}  = 'Borrower has no valid address.';
 224         $flaginfo{'noissues'} = 1;
 225         $flags{'GNA'}         = \%flaginfo;
 226     }
 227     if ( $patroninformation->{'lost'} && $patroninformation->{'lost'} == 1 ) {
 228         my %flaginfo;
 229         $flaginfo{'message'}  = 'Borrower\'s card reported lost.';
 230         $flaginfo{'noissues'} = 1;
 231         $flags{'LOST'}        = \%flaginfo;
 232     }
 233     if ( $patroninformation->{'debarred'} && check_date( split( /-/, $patroninformation->{'debarred'} ) ) ) {
 234         if ( Date_to_Days(Date::Calc::Today) < Date_to_Days( split( /-/, $patroninformation->{'debarred'} ) ) ) {
 235             my %flaginfo;
 236             $flaginfo{'debarredcomment'} = $patroninformation->{'debarredcomment'};
 237             $flaginfo{'message'}         = $patroninformation->{'debarredcomment'};
 238             $flaginfo{'noissues'}        = 1;
 239             $flaginfo{'dateend'}         = $patroninformation->{'debarred'};
 240             $flags{'DBARRED'}           = \%flaginfo;
 241         }
 242     }
 243     if (   $patroninformation->{'borrowernotes'}
 244         && $patroninformation->{'borrowernotes'} )
 245     {
 246         my %flaginfo;
 247         $flaginfo{'message'} = $patroninformation->{'borrowernotes'};
 248         $flags{'NOTES'}      = \%flaginfo;
 249     }
 250     my ( $odues, $itemsoverdue ) = C4::Overdues::checkoverdues($patroninformation->{'borrowernumber'});
 251     if ( $odues && $odues > 0 ) {
 252         my %flaginfo;
 253         $flaginfo{'message'}  = "Yes";
 254         $flaginfo{'itemlist'} = $itemsoverdue;
 255         foreach ( sort { $a->{'date_due'} cmp $b->{'date_due'} }
 256             @$itemsoverdue )
 257         {
 258             $flaginfo{'itemlisttext'} .=
 259               "$_->{'date_due'} $_->{'barcode'} $_->{'title'} \n";  # newline is display layer
 260         }
 261         $flags{'ODUES'} = \%flaginfo;
 262     }
 263
 264     my $waiting_holds = $patron->holds->search({ found => 'W' });
 265     my $nowaiting = $waiting_holds->count;
 266     if ( $nowaiting > 0 ) {
 267         my %flaginfo;
 268         $flaginfo{'message'}  = "Reserved items available";
 269         $flaginfo{'itemlist'} = $waiting_holds->unblessed;
 270         $flags{'WAITING'}     = \%flaginfo;
 271     }
 272     return ( \%flags );
 273 }
 274
 275
 276 =head2 ModMember
 277
 278   my $success = ModMember(borrowernumber => $borrowernumber,
 279                                             [ field => value ]... );
 280
 281 Modify borrower's data.  All date fields should ALREADY be in ISO format.
 282
 283 return :
 284 true on success, or false on failure
 285
 286 =cut
 287
 288 sub ModMember {
 289     my (%data) = @_;
 290
 291     # trim whitespace from data which has some non-whitespace in it.
 292     foreach my $field_name (keys(%data)) {
 293         if ( defined $data{$field_name} && $data{$field_name} =~ /\S/ ) {
 294             $data{$field_name} =~ s/^\s*|\s*$//g;
 295         }
 296     }
 297
 298     # test to know if you must update or not the borrower password
 299     if (exists $data{password}) {
 300         if ($data{password} eq '****' or $data{password} eq '') {
 301             delete $data{password};
 302         } else {
 303             if ( C4::Context->preference('NorwegianPatronDBEnable') && C4::Context->preference('NorwegianPatronDBEnable') == 1 ) {
 304                 # Update the hashed PIN in borrower_sync.hashed_pin, before Koha hashes it
 305                 Koha::NorwegianPatronDB::NLUpdateHashedPIN( $data{'borrowernumber'}, $data{password} );
 306             }
 307             $data{password} = hash_password($data{password});
 308         }
 309     }
 310
 311     my $old_categorycode = Koha::Patrons->find( $data{borrowernumber} )->categorycode;
 312
 313     # get only the columns of a borrower
 314     my $schema = Koha::Database->new()->schema;
 315     my @columns = $schema->source('Borrower')->columns;
 316     my $new_borrower = { map { join(' ', @columns) =~ /$_/ ? ( $_ => $data{$_} ) : () } keys(%data) };
 317
 318     $new_borrower->{dateofbirth}     ||= undef if exists $new_borrower->{dateofbirth};
 319     $new_borrower->{dateenrolled}    ||= undef if exists $new_borrower->{dateenrolled};
 320     $new_borrower->{dateexpiry}      ||= undef if exists $new_borrower->{dateexpiry};
 321     $new_borrower->{debarred}        ||= undef if exists $new_borrower->{debarred};
 322     $new_borrower->{sms_provider_id} ||= undef if exists $new_borrower->{sms_provider_id};
 323     $new_borrower->{guarantorid}     ||= undef if exists $new_borrower->{guarantorid};
 324
 325     my $patron = Koha::Patrons->find( $new_borrower->{borrowernumber} );
 326
 327     delete $new_borrower->{userid} if exists $new_borrower->{userid} and not $new_borrower->{userid};
 328
 329     my $execute_success = $patron->store if $patron->set($new_borrower);
 330
 331     if ($execute_success) { # only proceed if the update was a success
 332         # If the patron changes to a category with enrollment fee, we add a fee
 333         if ( $data{categorycode} and $data{categorycode} ne $old_categorycode ) {
 334             if ( C4::Context->preference('FeeOnChangePatronCategory') ) {
 335                 $patron->add_enrolment_fee_if_needed;
 336             }
 337         }
 338
 339         # If NorwegianPatronDBEnable is enabled, we set syncstatus to something that a
 340         # cronjob will use for syncing with NL
 341         if ( C4::Context->preference('NorwegianPatronDBEnable') && C4::Context->preference('NorwegianPatronDBEnable') == 1 ) {
 342             my $borrowersync = Koha::Database->new->schema->resultset('BorrowerSync')->find({
 343                 'synctype'       => 'norwegianpatrondb',
 344                 'borrowernumber' => $data{'borrowernumber'}
 345             });
 346             # Do not set to "edited" if syncstatus is "new". We need to sync as new before
 347             # we can sync as changed. And the "new sync" will pick up all changes since
 348             # the patron was created anyway.
 349             if ( $borrowersync->syncstatus ne 'new' && $borrowersync->syncstatus ne 'delete' ) {
 350                 $borrowersync->update( { 'syncstatus' => 'edited' } );
 351             }
 352             # Set the value of 'sync'
 353             $borrowersync->update( { 'sync' => $data{'sync'} } );
 354             # Try to do the live sync
 355             Koha::NorwegianPatronDB::NLSync({ 'borrowernumber' => $data{'borrowernumber'} });
 356         }
 357
 358         logaction("MEMBERS", "MODIFY", $data{'borrowernumber'}, "UPDATE (executed w/ arg: $data{'borrowernumber'})") if C4::Context->preference("BorrowersLog");
 359     }
 360     return $execute_success;
 361 }
 362
 363 =head2 AddMember
 364
 365   $borrowernumber = &AddMember(%borrower);
 366
 367 insert new borrower into table
 368
 369 (%borrower keys are database columns. Database columns could be
 370 different in different versions. Please look into database for correct
 371 column names.)
 372
 373 Returns the borrowernumber upon success
 374
 375 Returns as undef upon any db error without further processing
 376
 377 =cut
 378
 379 #'
 380 sub AddMember {
 381     my (%data) = @_;
 382     my $dbh = C4::Context->dbh;
 383     my $schema = Koha::Database->new()->schema;
 384
 385     my $category = Koha::Patron::Categories->find( $data{categorycode} );
 386     unless ($category) {
 387         Koha::Exceptions::BadParameter->throw(
 388             error => 'Invalid parameter passed',
 389             parameter => 'categorycode'
 390         );
 391     }
 392
 393     # trim whitespace from data which has some non-whitespace in it.
 394     foreach my $field_name (keys(%data)) {
 395         if ( defined $data{$field_name} && $data{$field_name} =~ /\S/ ) {
 396             $data{$field_name} =~ s/^\s*|\s*$//g;
 397         }
 398     }
 399
 400     # generate a proper login if none provided
 401     $data{'userid'} = Generate_Userid( $data{'borrowernumber'}, $data{'firstname'}, $data{'surname'} )
 402       if ( $data{'userid'} eq '' || !Check_Userid( $data{'userid'} ) );
 403
 404     # add expiration date if it isn't already there
 405     $data{dateexpiry} ||= $category->get_expiry_date;
 406
 407     # add enrollment date if it isn't already there
 408     unless ( $data{'dateenrolled'} ) {
 409         $data{'dateenrolled'} = output_pref( { dt => dt_from_string, dateonly => 1, dateformat => 'iso' } );
 410     }
 411
 412     if ( C4::Context->preference("autoMemberNum") ) {
 413         if ( not exists $data{cardnumber} or not defined $data{cardnumber} or $data{cardnumber} eq '' ) {
 414             $data{cardnumber} = fixup_cardnumber( $data{cardnumber} );
 415         }
 416     }
 417
 418     $data{'privacy'} =
 419         $category->default_privacy() eq 'default' ? 1
 420       : $category->default_privacy() eq 'never'   ? 2
 421       : $category->default_privacy() eq 'forever' ? 0
 422       :                                             undef;
 423
 424     $data{'privacy_guarantor_checkouts'} = 0 unless defined( $data{'privacy_guarantor_checkouts'} );
 425
 426     # Make a copy of the plain text password for later use
 427     my $plain_text_password = $data{'password'};
 428
 429     # create a disabled account if no password provided
 430     $data{'password'} = ($data{'password'})? hash_password($data{'password'}) : '!';
 431
 432     # we don't want invalid dates in the db (mysql has a bad habit of inserting 0000-00-00
 433     $data{'dateofbirth'}     = undef if ( not $data{'dateofbirth'} );
 434     $data{'debarred'}        = undef if ( not $data{'debarred'} );
 435     $data{'sms_provider_id'} = undef if ( not $data{'sms_provider_id'} );
 436     $data{'guarantorid'}     = undef if ( not $data{'guarantorid'} );
 437
 438     # get only the columns of Borrower
 439     # FIXME Do we really need this check?
 440     my @columns = $schema->source('Borrower')->columns;
 441     my $new_member = { map { join(' ',@columns) =~ /$_/ ? ( $_ => $data{$_} )  : () } keys(%data) } ;
 442
 443     delete $new_member->{borrowernumber};
 444
 445     my $patron = Koha::Patron->new( $new_member )->store;
 446     $data{borrowernumber} = $patron->borrowernumber;
 447
 448     # If NorwegianPatronDBEnable is enabled, we set syncstatus to something that a
 449     # cronjob will use for syncing with NL
 450     if ( exists $data{'borrowernumber'} && C4::Context->preference('NorwegianPatronDBEnable') && C4::Context->preference('NorwegianPatronDBEnable') == 1 ) {
 451         Koha::Database->new->schema->resultset('BorrowerSync')->create({
 452             'borrowernumber' => $data{'borrowernumber'},
 453             'synctype'       => 'norwegianpatrondb',
 454             'sync'           => 1,
 455             'syncstatus'     => 'new',
 456             'hashed_pin'     => Koha::NorwegianPatronDB::NLEncryptPIN( $plain_text_password ),
 457         });
 458     }
 459
 460     logaction("MEMBERS", "CREATE", $data{'borrowernumber'}, "") if C4::Context->preference("BorrowersLog");
 461
 462     $patron->add_enrolment_fee_if_needed;
 463
 464     return $data{borrowernumber};
 465 }
 466
 467 =head2 Check_Userid
 468
 469     my $uniqueness = Check_Userid($userid,$borrowernumber);
 470
 471     $borrowernumber is optional (i.e. it can contain a blank value). If $userid is passed with a blank $borrowernumber variable, the database will be checked for all instances of that userid (i.e. userid=? AND borrowernumber != '').
 472
 473     If $borrowernumber is provided, the database will be checked for every instance of that userid coupled with a different borrower(number) than the one provided.
 474
 475     return :
 476         0 for not unique (i.e. this $userid already exists)
 477         1 for unique (i.e. this $userid does not exist, or this $userid/$borrowernumber combination already exists)
 478
 479 =cut
 480
 481 sub Check_Userid {
 482     my ( $uid, $borrowernumber ) = @_;
 483
 484     return 0 unless ($uid); # userid is a unique column, we should assume NULL is not unique
 485
 486     return 0 if ( $uid eq C4::Context->config('user') );
 487
 488     my $rs = Koha::Database->new()->schema()->resultset('Borrower');
 489
 490     my $params;
 491     $params->{userid} = $uid;
 492     $params->{borrowernumber} = { '!=' => $borrowernumber } if ($borrowernumber);
 493
 494     my $count = $rs->count( $params );
 495
 496     return $count ? 0 : 1;
 497 }
 498
 499 =head2 Generate_Userid
 500
 501     my $newuid = Generate_Userid($borrowernumber, $firstname, $surname);
 502
 503     Generate a userid using the $surname and the $firstname (if there is a value in $firstname).
 504
 505     $borrowernumber is optional (i.e. it can contain a blank value). A value is passed when generating a new userid for an existing borrower. When a new userid is created for a new borrower, a blank value is passed to this sub.
 506
 507     return :
 508         new userid ($firstname.$surname if there is a $firstname, or $surname if there is no value in $firstname) plus offset (0 if the $newuid is unique, or a higher numeric value if Check_Userid finds an existing match for the $newuid in the database).
 509
 510 =cut
 511
 512 sub Generate_Userid {
 513   my ($borrowernumber, $firstname, $surname) = @_;
 514   my $newuid;
 515   my $offset = 0;
 516   #The script will "do" the following code and increment the $offset until Check_Userid = 1 (i.e. until $newuid comes back as unique)
 517   do {
 518     $firstname =~ s/[[:digit:][:space:][:blank:][:punct:][:cntrl:]]//g;
 519     $surname =~ s/[[:digit:][:space:][:blank:][:punct:][:cntrl:]]//g;
 520     $newuid = lc(($firstname)? "$firstname.$surname" : $surname);
 521     $newuid = unac_string('utf-8',$newuid);
 522     $newuid .= $offset unless $offset == 0;
 523     $offset++;
 524
 525    } while (!Check_Userid($newuid,$borrowernumber));
 526
 527    return $newuid;
 528 }
 529
 530 =head2 fixup_cardnumber
 531
 532 Warning: The caller is responsible for locking the members table in write
 533 mode, to avoid database corruption.
 534
 535 =cut
 536
 537 use vars qw( @weightings );
 538 my @weightings = ( 8, 4, 6, 3, 5, 2, 1 );
 539
 540 sub fixup_cardnumber {
 541     my ($cardnumber) = @_;
 542     my $autonumber_members = C4::Context->boolean_preference('autoMemberNum') || 0;
 543
 544     # Find out whether member numbers should be generated
 545     # automatically. Should be either "1" or something else.
 546     # Defaults to "0", which is interpreted as "no".
 547
 548     #     if ($cardnumber !~ /\S/ && $autonumber_members) {
 549     ($autonumber_members) or return $cardnumber;
 550     my $checkdigit = C4::Context->preference('checkdigit');
 551     my $dbh = C4::Context->dbh;
 552     if ( $checkdigit and $checkdigit eq 'katipo' ) {
 553
 554         # if checkdigit is selected, calculate katipo-style cardnumber.
 555         # otherwise, just use the max()
 556         # purpose: generate checksum'd member numbers.
 557         # We'll assume we just got the max value of digits 2-8 of member #'s
 558         # from the database and our job is to increment that by one,
 559         # determine the 1st and 9th digits and return the full string.
 560         my $sth = $dbh->prepare(
 561             "select max(substring(borrowers.cardnumber,2,7)) as new_num from borrowers"
 562         );
 563         $sth->execute;
 564         my $data = $sth->fetchrow_hashref;
 565         $cardnumber = $data->{new_num};
 566         if ( !$cardnumber ) {    # If DB has no values,
 567             $cardnumber = 1000000;    # start at 1000000
 568         } else {
 569             $cardnumber += 1;
 570         }
 571
 572         my $sum = 0;
 573         for ( my $i = 0 ; $i < 8 ; $i += 1 ) {
 574             # read weightings, left to right, 1 char at a time
 575             my $temp1 = $weightings[$i];
 576
 577             # sequence left to right, 1 char at a time
 578             my $temp2 = substr( $cardnumber, $i, 1 );
 579
 580             # mult each char 1-7 by its corresponding weighting
 581             $sum += $temp1 * $temp2;
 582         }
 583
 584         my $rem = ( $sum % 11 );
 585         $rem = 'X' if $rem == 10;
 586
 587         return "V$cardnumber$rem";
 588      } else {
 589
 590         my $sth = $dbh->prepare(
 591             'SELECT MAX( CAST( cardnumber AS SIGNED ) ) FROM borrowers WHERE cardnumber REGEXP "^-?[0-9]+$"'
 592         );
 593         $sth->execute;
 594         my ($result) = $sth->fetchrow;
 595         return $result + 1;
 596     }
 597     return $cardnumber;     # just here as a fallback/reminder
 598 }
 599
 600 =head2 GetPendingIssues
 601
 602   my $issues = &GetPendingIssues(@borrowernumber);
 603
 604 Looks up what the patron with the given borrowernumber has borrowed.
 605
 606 C<&GetPendingIssues> returns a
 607 reference-to-array where each element is a reference-to-hash; the
 608 keys are the fields from the C<issues>, C<biblio>, and C<items> tables.
 609 The keys include C<biblioitems> fields.
 610
 611 =cut
 612
 613 sub GetPendingIssues {
 614     my @borrowernumbers = @_;
 615
 616     unless (@borrowernumbers ) { # return a ref_to_array
 617         return \@borrowernumbers; # to not cause surprise to caller
 618     }
 619
 620     # Borrowers part of the query
 621     my $bquery = '';
 622     for (my $i = 0; $i < @borrowernumbers; $i++) {
 623         $bquery .= ' issues.borrowernumber = ?';
 624         if ($i < $#borrowernumbers ) {
 625             $bquery .= ' OR';
 626         }
 627     }
 628
 629     # FIXME: namespace collision: each table has "timestamp" fields.  Which one is "timestamp" ?
 630     # FIXME: circ/ciculation.pl tries to sort by timestamp!
 631     # FIXME: namespace collision: other collisions possible.
 632     # FIXME: most of this data isn't really being used by callers.
 633     my $query =
 634    "SELECT issues.*,
 635             items.*,
 636            biblio.*,
 637            biblioitems.volume,
 638            biblioitems.number,
 639            biblioitems.itemtype,
 640            biblioitems.isbn,
 641            biblioitems.issn,
 642            biblioitems.publicationyear,
 643            biblioitems.publishercode,
 644            biblioitems.volumedate,
 645            biblioitems.volumedesc,
 646            biblioitems.lccn,
 647            biblioitems.url,
 648            borrowers.firstname,
 649            borrowers.surname,
 650            borrowers.cardnumber,
 651            issues.timestamp AS timestamp,
 652            issues.renewals  AS renewals,
 653            issues.borrowernumber AS borrowernumber,
 654             items.renewals  AS totalrenewals
 655     FROM   issues
 656     LEFT JOIN items       ON items.itemnumber       =      issues.itemnumber
 657     LEFT JOIN biblio      ON items.biblionumber     =      biblio.biblionumber
 658     LEFT JOIN biblioitems ON items.biblioitemnumber = biblioitems.biblioitemnumber
 659     LEFT JOIN borrowers ON issues.borrowernumber = borrowers.borrowernumber
 660     WHERE
 661       $bquery
 662     ORDER BY issues.issuedate"
 663     ;
 664
 665     my $sth = C4::Context->dbh->prepare($query);
 666     $sth->execute(@borrowernumbers);
 667     my $data = $sth->fetchall_arrayref({});
 668     my $today = dt_from_string;
 669     foreach (@{$data}) {
 670         if ($_->{issuedate}) {
 671             $_->{issuedate} = dt_from_string($_->{issuedate}, 'sql');
 672         }
 673         $_->{date_due_sql} = $_->{date_due};
 674         # FIXME no need to have this value
 675         $_->{date_due} or next;
 676         $_->{date_due_sql} = $_->{date_due};
 677         # FIXME no need to have this value
 678         $_->{date_due} = dt_from_string($_->{date_due}, 'sql');
 679         if ( DateTime->compare($_->{date_due}, $today) == -1 ) {
 680             $_->{overdue} = 1;
 681         }
 682     }
 683     return $data;
 684 }
 685
 686 =head2 GetAllIssues
 687
 688   $issues = &GetAllIssues($borrowernumber, $sortkey, $limit);
 689
 690 Looks up what the patron with the given borrowernumber has borrowed,
 691 and sorts the results.
 692
 693 C<$sortkey> is the name of a field on which to sort the results. This
 694 should be the name of a field in the C<issues>, C<biblio>,
 695 C<biblioitems>, or C<items> table in the Koha database.
 696
 697 C<$limit> is the maximum number of results to return.
 698
 699 C<&GetAllIssues> an arrayref, C<$issues>, of hashrefs, the keys of which
 700 are the fields from the C<issues>, C<biblio>, C<biblioitems>, and
 701 C<items> tables of the Koha database.
 702
 703 =cut
 704
 705 #'
 706 sub GetAllIssues {
 707     my ( $borrowernumber, $order, $limit ) = @_;
 708
 709     return unless $borrowernumber;
 710     $order = 'date_due desc' unless $order;
 711
 712     my $dbh = C4::Context->dbh;
 713     my $query =
 714 'SELECT *, issues.timestamp as issuestimestamp, issues.renewals AS renewals,items.renewals AS totalrenewals,items.timestamp AS itemstimestamp
 715   FROM issues
 716   LEFT JOIN items on items.itemnumber=issues.itemnumber
 717   LEFT JOIN biblio ON items.biblionumber=biblio.biblionumber
 718   LEFT JOIN biblioitems ON items.biblioitemnumber=biblioitems.biblioitemnumber
 719   WHERE borrowernumber=?
 720   UNION ALL
 721   SELECT *, old_issues.timestamp as issuestimestamp, old_issues.renewals AS renewals,items.renewals AS totalrenewals,items.timestamp AS itemstimestamp
 722   FROM old_issues
 723   LEFT JOIN items on items.itemnumber=old_issues.itemnumber
 724   LEFT JOIN biblio ON items.biblionumber=biblio.biblionumber
 725   LEFT JOIN biblioitems ON items.biblioitemnumber=biblioitems.biblioitemnumber
 726   WHERE borrowernumber=? AND old_issues.itemnumber IS NOT NULL
 727   order by ' . $order;
 728     if ($limit) {
 729         $query .= " limit $limit";
 730     }
 731
 732     my $sth = $dbh->prepare($query);
 733     $sth->execute( $borrowernumber, $borrowernumber );
 734     return $sth->fetchall_arrayref( {} );
 735 }
 736
 737 sub checkcardnumber {
 738     my ( $cardnumber, $borrowernumber ) = @_;
 739
 740     # If cardnumber is null, we assume they're allowed.
 741     return 0 unless defined $cardnumber;
 742
 743     my $dbh = C4::Context->dbh;
 744     my $query = "SELECT * FROM borrowers WHERE cardnumber=?";
 745     $query .= " AND borrowernumber <> ?" if ($borrowernumber);
 746     my $sth = $dbh->prepare($query);
 747     $sth->execute(
 748         $cardnumber,
 749         ( $borrowernumber ? $borrowernumber : () )
 750     );
 751
 752     return 1 if $sth->fetchrow_hashref;
 753
 754     my ( $min_length, $max_length ) = get_cardnumber_length();
 755     return 2
 756         if length $cardnumber > $max_length
 757         or length $cardnumber < $min_length;
 758
 759     return 0;
 760 }
 761
 762 =head2 get_cardnumber_length
 763
 764     my ($min, $max) = C4::Members::get_cardnumber_length()
 765
 766 Returns the minimum and maximum length for patron cardnumbers as
 767 determined by the CardnumberLength system preference, the
 768 BorrowerMandatoryField system preference, and the width of the
 769 database column.
 770
 771 =cut
 772
 773 sub get_cardnumber_length {
 774     my $borrower = Koha::Schema->resultset('Borrower');
 775     my $field_size = $borrower->result_source->column_info('cardnumber')->{size};
 776     my ( $min, $max ) = ( 0, $field_size ); # borrowers.cardnumber is a nullable varchar(20)
 777     $min = 1 if C4::Context->preference('BorrowerMandatoryField') =~ /cardnumber/;
 778     if ( my $cardnumber_length = C4::Context->preference('CardnumberLength') ) {
 779         # Is integer and length match
 780         if ( $cardnumber_length =~ m|^\d+$| ) {
 781             $min = $max = $cardnumber_length
 782                 if $cardnumber_length >= $min
 783                     and $cardnumber_length <= $max;
 784         }
 785         # Else assuming it is a range
 786         elsif ( $cardnumber_length =~ m|(\d*),(\d*)| ) {
 787             $min = $1 if $1 and $min < $1;
 788             $max = $2 if $2 and $max > $2;
 789         }
 790
 791     }
 792     $min = $max if $min > $max;
 793     return ( $min, $max );
 794 }
 795
 796 =head2 GetBorrowersToExpunge
 797
 798   $borrowers = &GetBorrowersToExpunge(
 799       not_borrowed_since => $not_borrowed_since,
 800       expired_before       => $expired_before,
 801       category_code        => $category_code,
 802       patron_list_id       => $patron_list_id,
 803       branchcode           => $branchcode
 804   );
 805
 806   This function get all borrowers based on the given criteria.
 807
 808 =cut
 809
 810 sub GetBorrowersToExpunge {
 811
 812     my $params = shift;
 813     my $filterdate       = $params->{'not_borrowed_since'};
 814     my $filterexpiry     = $params->{'expired_before'};
 815     my $filterlastseen   = $params->{'last_seen'};
 816     my $filtercategory   = $params->{'category_code'};
 817     my $filterbranch     = $params->{'branchcode'} ||
 818                         ((C4::Context->preference('IndependentBranches')
 819                              && C4::Context->userenv
 820                              && !C4::Context->IsSuperLibrarian()
 821                              && C4::Context->userenv->{branch})
 822                          ? C4::Context->userenv->{branch}
 823                          : "");
 824     my $filterpatronlist = $params->{'patron_list_id'};
 825
 826     my $dbh   = C4::Context->dbh;
 827     my $query = q|
 828         SELECT *
 829         FROM (
 830             SELECT borrowers.borrowernumber,
 831                    MAX(old_issues.timestamp) AS latestissue,
 832                    MAX(issues.timestamp) AS currentissue
 833             FROM   borrowers
 834             JOIN   categories USING (categorycode)
 835             LEFT JOIN (
 836                 SELECT guarantorid
 837                 FROM borrowers
 838                 WHERE guarantorid IS NOT NULL
 839                     AND guarantorid <> 0
 840             ) as tmp ON borrowers.borrowernumber=tmp.guarantorid
 841             LEFT JOIN old_issues USING (borrowernumber)
 842             LEFT JOIN issues USING (borrowernumber)|;
 843     if ( $filterpatronlist  ){
 844         $query .= q| LEFT JOIN patron_list_patrons USING (borrowernumber)|;
 845     }
 846     $query .= q| WHERE  category_type <> 'S'
 847         AND tmp.guarantorid IS NULL
 848     |;
 849     my @query_params;
 850     if ( $filterbranch && $filterbranch ne "" ) {
 851         $query.= " AND borrowers.branchcode = ? ";
 852         push( @query_params, $filterbranch );
 853     }
 854     if ( $filterexpiry ) {
 855         $query .= " AND dateexpiry < ? ";
 856         push( @query_params, $filterexpiry );
 857     }
 858     if ( $filterlastseen ) {
 859         $query .= ' AND lastseen < ? ';
 860         push @query_params, $filterlastseen;
 861     }
 862     if ( $filtercategory ) {
 863         $query .= " AND categorycode = ? ";
 864         push( @query_params, $filtercategory );
 865     }
 866     if ( $filterpatronlist ){
 867         $query.=" AND patron_list_id = ? ";
 868         push( @query_params, $filterpatronlist );
 869     }
 870     $query .= " GROUP BY borrowers.borrowernumber";
 871     $query .= q|
 872         ) xxx WHERE currentissue IS NULL|;
 873     if ( $filterdate ) {
 874         $query.=" AND ( latestissue < ? OR latestissue IS NULL ) ";
 875         push @query_params,$filterdate;
 876     }
 877
 878     warn $query if $debug;
 879
 880     my $sth = $dbh->prepare($query);
 881     if (scalar(@query_params)>0){
 882         $sth->execute(@query_params);
 883     }
 884     else {
 885         $sth->execute;
 886     }
 887
 888     my @results;
 889     while ( my $data = $sth->fetchrow_hashref ) {
 890         push @results, $data;
 891     }
 892     return \@results;
 893 }
 894
 895 =head2 IssueSlip
 896
 897   IssueSlip($branchcode, $borrowernumber, $quickslip)
 898
 899   Returns letter hash ( see C4::Letters::GetPreparedLetter )
 900
 901   $quickslip is boolean, to indicate whether we want a quick slip
 902
 903   IssueSlip populates ISSUESLIP and ISSUEQSLIP, and will make the following expansions:
 904
 905   Both slips:
 906
 907       <<branches.*>>
 908       <<borrowers.*>>
 909
 910   ISSUESLIP:
 911
 912       <checkedout>
 913          <<biblio.*>>
 914          <<items.*>>
 915          <<biblioitems.*>>
 916          <<issues.*>>
 917       </checkedout>
 918
 919       <overdue>
 920          <<biblio.*>>
 921          <<items.*>>
 922          <<biblioitems.*>>
 923          <<issues.*>>
 924       </overdue>
 925
 926       <news>
 927          <<opac_news.*>>
 928       </news>
 929
 930   ISSUEQSLIP:
 931
 932       <checkedout>
 933          <<biblio.*>>
 934          <<items.*>>
 935          <<biblioitems.*>>
 936          <<issues.*>>
 937       </checkedout>
 938
 939   NOTE: Not all table fields are available, pleasee see GetPendingIssues for a list of available fields.
 940
 941 =cut
 942
 943 sub IssueSlip {
 944     my ($branch, $borrowernumber, $quickslip) = @_;
 945
 946     # FIXME Check callers before removing this statement
 947     #return unless $borrowernumber;
 948
 949     my $patron = Koha::Patrons->find( $borrowernumber );
 950     return unless $patron;
 951
 952     my @issues = @{ GetPendingIssues($borrowernumber) };
 953
 954     for my $issue (@issues) {
 955         $issue->{date_due} = $issue->{date_due_sql};
 956         if ($quickslip) {
 957             my $today = output_pref({ dt => dt_from_string, dateformat => 'iso', dateonly => 1 });
 958             if ( substr( $issue->{issuedate}, 0, 10 ) eq $today
 959                 or substr( $issue->{lastreneweddate}, 0, 10 ) eq $today ) {
 960                   $issue->{now} = 1;
 961             };
 962         }
 963     }
 964
 965     # Sort on timestamp then on issuedate then on issue_id
 966     # useful for tests and could be if modified in a batch
 967     @issues = sort {
 968             $b->{timestamp} <=> $a->{timestamp}
 969          or $b->{issuedate} <=> $a->{issuedate}
 970          or $b->{issue_id}  <=> $a->{issue_id}
 971     } @issues;
 972
 973     my ($letter_code, %repeat, %loops);
 974     if ( $quickslip ) {
 975         $letter_code = 'ISSUEQSLIP';
 976         my @checkouts = map {
 977                 'biblio'       => $_,
 978                 'items'        => $_,
 979                 'biblioitems'  => $_,
 980                 'issues'       => $_,
 981             }, grep { $_->{'now'} } @issues;
 982         %repeat =  (
 983             checkedout => \@checkouts, # History syntax
 984         );
 985         %loops = (
 986             issues => [ map { $_->{issues}{itemnumber} } @checkouts ], # TT syntax
 987         );
 988     }
 989     else {
 990         my @checkouts = map {
 991             'biblio'        => $_,
 992               'items'       => $_,
 993               'biblioitems' => $_,
 994               'issues'      => $_,
 995         }, grep { !$_->{'overdue'} } @issues;
 996         my @overdues = map {
 997             'biblio'        => $_,
 998               'items'       => $_,
 999               'biblioitems' => $_,
1000               'issues'      => $_,
1001         }, grep { $_->{'overdue'} } @issues;
1002         my $news = GetNewsToDisplay( "slip", $branch );
1003         my @news = map {
1004             $_->{'timestamp'} = $_->{'newdate'};
1005             { opac_news => $_ }
1006         } @$news;
1007         $letter_code = 'ISSUESLIP';
1008         %repeat      = (
1009             checkedout => \@checkouts,
1010             overdue    => \@overdues,
1011             news       => \@news,
1012         );
1013         %loops = (
1014             issues => [ map { $_->{issues}{itemnumber} } @checkouts ],
1015             overdues   => [ map { $_->{issues}{itemnumber} } @overdues ],
1016             opac_news => [ map { $_->{opac_news}{idnew} } @news ],
1017         );
1018     }
1019
1020     return  C4::Letters::GetPreparedLetter (
1021         module => 'circulation',
1022         letter_code => $letter_code,
1023         branchcode => $branch,
1024         lang => $patron->lang,
1025         tables => {
1026             'branches'    => $branch,
1027             'borrowers'   => $borrowernumber,
1028         },
1029         repeat => \%repeat,
1030         loops => \%loops,
1031     );
1032 }
1033
1034 =head2 AddMember_Auto
1035
1036 =cut
1037
1038 sub AddMember_Auto {
1039     my ( %borrower ) = @_;
1040
1041     $borrower{'cardnumber'} ||= fixup_cardnumber();
1042
1043     $borrower{'borrowernumber'} = AddMember(%borrower);
1044
1045     return ( %borrower );
1046 }
1047
1048 =head2 AddMember_Opac
1049
1050 =cut
1051
1052 sub AddMember_Opac {
1053     my ( %borrower ) = @_;
1054
1055     $borrower{'categorycode'} //= C4::Context->preference('PatronSelfRegistrationDefaultCategory');
1056     if (not defined $borrower{'password'}){
1057         my $sr = new String::Random;
1058         $sr->{'A'} = [ 'A'..'Z', 'a'..'z' ];
1059         my $password = $sr->randpattern("AAAAAAAAAA");
1060         $borrower{'password'} = $password;
1061     }
1062
1063     %borrower = AddMember_Auto(%borrower);
1064
1065     return ( $borrower{'borrowernumber'}, $borrower{'password'} );
1066 }
1067
1068 =head2 DeleteExpiredOpacRegistrations
1069
1070     Delete accounts that haven't been upgraded from the 'temporary' category
1071     Returns the number of removed patrons
1072
1073 =cut
1074
1075 sub DeleteExpiredOpacRegistrations {
1076
1077     my $delay = C4::Context->preference('PatronSelfRegistrationExpireTemporaryAccountsDelay');
1078     my $category_code = C4::Context->preference('PatronSelfRegistrationDefaultCategory');
1079
1080     return 0 if not $category_code or not defined $delay or $delay eq q||;
1081
1082     my $query = qq|
1083 SELECT borrowernumber
1084 FROM borrowers
1085 WHERE categorycode = ? AND DATEDIFF( NOW(), dateenrolled ) > ? |;
1086
1087     my $dbh = C4::Context->dbh;
1088     my $sth = $dbh->prepare($query);
1089     $sth->execute( $category_code, $delay );
1090     my $cnt=0;
1091     while ( my ($borrowernumber) = $sth->fetchrow_array() ) {
1092         Koha::Patrons->find($borrowernumber)->delete;
1093         $cnt++;
1094     }
1095     return $cnt;
1096 }
1097
1098 =head2 DeleteUnverifiedOpacRegistrations
1099
1100     Delete all unverified self registrations in borrower_modifications,
1101     older than the specified number of days.
1102
1103 =cut
1104
1105 sub DeleteUnverifiedOpacRegistrations {
1106     my ( $days ) = @_;
1107     my $dbh = C4::Context->dbh;
1108     my $sql=qq|
1109 DELETE FROM borrower_modifications
1110 WHERE borrowernumber = 0 AND DATEDIFF( NOW(), timestamp ) > ?|;
1111     my $cnt=$dbh->do($sql, undef, ($days) );
1112     return $cnt eq '0E0'? 0: $cnt;
1113 }
1114
1115 sub GetOverduesForPatron {
1116     my ( $borrowernumber ) = @_;
1117
1118     my $sql = "
1119         SELECT *
1120         FROM issues, items, biblio, biblioitems
1121         WHERE items.itemnumber=issues.itemnumber
1122           AND biblio.biblionumber   = items.biblionumber
1123           AND biblio.biblionumber   = biblioitems.biblionumber
1124           AND issues.borrowernumber = ?
1125           AND date_due < NOW()
1126     ";
1127
1128     my $sth = C4::Context->dbh->prepare( $sql );
1129     $sth->execute( $borrowernumber );
1130
1131     return $sth->fetchall_arrayref({});
1132 }
1133
1134 END { }    # module clean-up code here (global destructor)
1135
1136 1;
1137
1138 __END__
1139
1140 =head1 AUTHOR
1141
1142 Koha Team
1143
1144 =cut