3 # Copyright 2000-2003 Katipo Communications
4 # Copyright 2010 BibLibre
5 # Parts Copyright 2010 Catalyst IT
7 # This file is part of Koha.
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.
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.
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>.
24 #use warnings; FIXME - Bug 2505
26 use String::Random qw( random_string );
27 use Scalar::Util qw( looks_like_number );
28 use Date::Calc qw/Today Add_Delta_YM check_date Date_to_Days/;
29 use C4::Log; # logaction
35 use C4::Members::Attributes qw(SearchIdMatchingAttribute UpdateBorrowerAttribute);
36 use C4::NewsChannels; #get slip news
40 use Text::Unaccent qw( unac_string );
41 use Koha::AuthUtils qw(hash_password);
44 use Koha::List::Patron;
47 our (@ISA,@EXPORT,@EXPORT_OK,$debug);
49 use Module::Load::Conditional qw( can_load );
50 if ( ! can_load( modules => { 'Koha::NorwegianPatronDB' => undef } ) ) {
51 $debug && warn "Unable to load Koha::NorwegianPatronDB";
56 $debug = $ENV{DEBUG} || 0;
65 &GetMemberIssuesAndFines
69 &GetFirstValidEmailAddress
70 &GetNoticeEmailAddress
75 &GetHideLostItemsPreference
78 &GetMemberAccountRecords
79 &GetBorNotifyAcctRecord
82 GetBorrowerCategorycode
83 &GetBorrowercategoryList
85 &GetBorrowersToExpunge
86 &GetBorrowersWhoHaveNeverBorrowed
87 &GetBorrowersWithIssuesHistoryOlderThan
90 &GetUpcomingMembershipExpires
115 &ExtendMemberSubscriptionTo
131 C4::Members - Perl Module containing convenience functions for member handling
139 This module contains routines for adding, modifying and deleting members/patrons/borrowers
143 =head2 GetMemberDetails
145 ($borrower) = &GetMemberDetails($borrowernumber, $cardnumber);
147 Looks up a patron and returns information about him or her. If
148 C<$borrowernumber> is true (nonzero), C<&GetMemberDetails> looks
149 up the borrower by number; otherwise, it looks up the borrower by card
152 C<$borrower> is a reference-to-hash whose keys are the fields of the
153 borrowers table in the Koha database. In addition,
154 C<$borrower-E<gt>{flags}> is a hash giving more detailed information
155 about the patron. Its keys act as flags :
157 if $borrower->{flags}->{LOST} {
158 # Patron's card was reported lost
161 If the state of a flag means that the patron should not be
162 allowed to borrow any more books, then it will have a C<noissues> key
165 See patronflags for more details.
167 C<$borrower-E<gt>{authflags}> is a hash giving more detailed information
168 about the top-level permissions flags set for the borrower. For example,
169 if a user has the "editcatalogue" permission,
170 C<$borrower-E<gt>{authflags}-E<gt>{editcatalogue}> will exist and have
175 sub GetMemberDetails {
176 my ( $borrowernumber, $cardnumber ) = @_;
177 my $dbh = C4::Context->dbh;
180 if ($borrowernumber) {
181 $sth = $dbh->prepare("
184 categories.description,
185 categories.BlockExpiredPatronOpacActions,
189 LEFT JOIN categories ON borrowers.categorycode=categories.categorycode
190 WHERE borrowernumber = ?
192 $sth->execute($borrowernumber);
194 elsif ($cardnumber) {
195 $sth = $dbh->prepare("
198 categories.description,
199 categories.BlockExpiredPatronOpacActions,
203 LEFT JOIN categories ON borrowers.categorycode = categories.categorycode
206 $sth->execute($cardnumber);
211 my $borrower = $sth->fetchrow_hashref;
212 return unless $borrower;
213 my ($amount) = GetMemberAccountRecords($borrower->{borrowernumber});
214 $borrower->{'amountoutstanding'} = $amount;
215 # FIXME - patronflags calls GetMemberAccountRecords... just have patronflags return $amount
216 my $flags = patronflags( $borrower);
219 $sth = $dbh->prepare("select bit,flag from userflags");
221 while ( my ( $bit, $flag ) = $sth->fetchrow ) {
222 if ( $borrower->{'flags'} && $borrower->{'flags'} & 2**$bit ) {
223 $accessflagshash->{$flag} = 1;
226 $borrower->{'flags'} = $flags;
227 $borrower->{'authflags'} = $accessflagshash;
229 # Handle setting the true behavior for BlockExpiredPatronOpacActions
230 $borrower->{'BlockExpiredPatronOpacActions'} =
231 C4::Context->preference('BlockExpiredPatronOpacActions')
232 if ( $borrower->{'BlockExpiredPatronOpacActions'} == -1 );
234 $borrower->{'is_expired'} = 0;
235 $borrower->{'is_expired'} = 1 if
236 defined($borrower->{dateexpiry}) &&
237 $borrower->{'dateexpiry'} ne '0000-00-00' &&
238 Date_to_Days( Today() ) >
239 Date_to_Days( split /-/, $borrower->{'dateexpiry'} );
241 return ($borrower); #, $flags, $accessflagshash);
246 $flags = &patronflags($patron);
248 This function is not exported.
250 The following will be set where applicable:
251 $flags->{CHARGES}->{amount} Amount of debt
252 $flags->{CHARGES}->{noissues} Set if debt amount >$5.00 (or syspref noissuescharge)
253 $flags->{CHARGES}->{message} Message -- deprecated
255 $flags->{CREDITS}->{amount} Amount of credit
256 $flags->{CREDITS}->{message} Message -- deprecated
258 $flags->{ GNA } Patron has no valid address
259 $flags->{ GNA }->{noissues} Set for each GNA
260 $flags->{ GNA }->{message} "Borrower has no valid address" -- deprecated
262 $flags->{ LOST } Patron's card reported lost
263 $flags->{ LOST }->{noissues} Set for each LOST
264 $flags->{ LOST }->{message} Message -- deprecated
266 $flags->{DBARRED} Set if patron debarred, no access
267 $flags->{DBARRED}->{noissues} Set for each DBARRED
268 $flags->{DBARRED}->{message} Message -- deprecated
271 $flags->{ NOTES }->{message} The note itself. NOT deprecated
273 $flags->{ ODUES } Set if patron has overdue books.
274 $flags->{ ODUES }->{message} "Yes" -- deprecated
275 $flags->{ ODUES }->{itemlist} ref-to-array: list of overdue books
276 $flags->{ ODUES }->{itemlisttext} Text list of overdue items -- deprecated
278 $flags->{WAITING} Set if any of patron's reserves are available
279 $flags->{WAITING}->{message} Message -- deprecated
280 $flags->{WAITING}->{itemlist} ref-to-array: list of available items
284 =item C<$flags-E<gt>{ODUES}-E<gt>{itemlist}> is a reference-to-array listing the
285 overdue items. Its elements are references-to-hash, each describing an
286 overdue item. The keys are selected fields from the issues, biblio,
287 biblioitems, and items tables of the Koha database.
289 =item C<$flags-E<gt>{ODUES}-E<gt>{itemlisttext}> is a string giving a text listing of
290 the overdue items, one per line. Deprecated.
292 =item C<$flags-E<gt>{WAITING}-E<gt>{itemlist}> is a reference-to-array listing the
293 available items. Each element is a reference-to-hash whose keys are
294 fields from the reserves table of the Koha database.
298 All the "message" fields that include language generated in this function are deprecated,
299 because such strings belong properly in the display layer.
301 The "message" field that comes from the DB is OK.
305 # TODO: use {anonymous => hashes} instead of a dozen %flaginfo
306 # FIXME rename this function.
309 my ( $patroninformation) = @_;
310 my $dbh=C4::Context->dbh;
311 my ($balance, $owing) = GetMemberAccountBalance( $patroninformation->{'borrowernumber'});
314 my $noissuescharge = C4::Context->preference("noissuescharge") || 5;
315 $flaginfo{'message'} = sprintf 'Patron owes %.02f', $owing;
316 $flaginfo{'amount'} = sprintf "%.02f", $owing;
317 if ( $owing > $noissuescharge && !C4::Context->preference("AllowFineOverride") ) {
318 $flaginfo{'noissues'} = 1;
320 $flags{'CHARGES'} = \%flaginfo;
322 elsif ( $balance < 0 ) {
324 $flaginfo{'message'} = sprintf 'Patron has credit of %.02f', -$balance;
325 $flaginfo{'amount'} = sprintf "%.02f", $balance;
326 $flags{'CREDITS'} = \%flaginfo;
329 # Check the debt of the guarntees of this patron
330 my $no_issues_charge_guarantees = C4::Context->preference("NoIssuesChargeGuarantees");
331 $no_issues_charge_guarantees = undef unless looks_like_number( $no_issues_charge_guarantees );
332 if ( defined $no_issues_charge_guarantees ) {
333 my $p = Koha::Patrons->find( $patroninformation->{borrowernumber} );
334 my @guarantees = $p->guarantees();
335 my $guarantees_non_issues_charges;
336 foreach my $g ( @guarantees ) {
337 my ( $b, $n, $o ) = C4::Members::GetMemberAccountBalance( $g->id );
338 $guarantees_non_issues_charges += $n;
341 if ( $guarantees_non_issues_charges > $no_issues_charge_guarantees ) {
343 $flaginfo{'message'} = sprintf 'patron guarantees owe %.02f', $guarantees_non_issues_charges;
344 $flaginfo{'amount'} = $guarantees_non_issues_charges;
345 $flaginfo{'noissues'} = 1 unless C4::Context->preference("allowfineoverride");
346 $flags{'CHARGES_GUARANTEES'} = \%flaginfo;
350 if ( $patroninformation->{'gonenoaddress'}
351 && $patroninformation->{'gonenoaddress'} == 1 )
354 $flaginfo{'message'} = 'Borrower has no valid address.';
355 $flaginfo{'noissues'} = 1;
356 $flags{'GNA'} = \%flaginfo;
358 if ( $patroninformation->{'lost'} && $patroninformation->{'lost'} == 1 ) {
360 $flaginfo{'message'} = 'Borrower\'s card reported lost.';
361 $flaginfo{'noissues'} = 1;
362 $flags{'LOST'} = \%flaginfo;
364 if ( $patroninformation->{'debarred'} && check_date( split( /-/, $patroninformation->{'debarred'} ) ) ) {
365 if ( Date_to_Days(Date::Calc::Today) < Date_to_Days( split( /-/, $patroninformation->{'debarred'} ) ) ) {
367 $flaginfo{'debarredcomment'} = $patroninformation->{'debarredcomment'};
368 $flaginfo{'message'} = $patroninformation->{'debarredcomment'};
369 $flaginfo{'noissues'} = 1;
370 $flaginfo{'dateend'} = $patroninformation->{'debarred'};
371 $flags{'DBARRED'} = \%flaginfo;
374 if ( $patroninformation->{'borrowernotes'}
375 && $patroninformation->{'borrowernotes'} )
378 $flaginfo{'message'} = $patroninformation->{'borrowernotes'};
379 $flags{'NOTES'} = \%flaginfo;
381 my ( $odues, $itemsoverdue ) = C4::Overdues::checkoverdues($patroninformation->{'borrowernumber'});
382 if ( $odues && $odues > 0 ) {
384 $flaginfo{'message'} = "Yes";
385 $flaginfo{'itemlist'} = $itemsoverdue;
386 foreach ( sort { $a->{'date_due'} cmp $b->{'date_due'} }
389 $flaginfo{'itemlisttext'} .=
390 "$_->{'date_due'} $_->{'barcode'} $_->{'title'} \n"; # newline is display layer
392 $flags{'ODUES'} = \%flaginfo;
394 my @itemswaiting = C4::Reserves::GetReservesFromBorrowernumber( $patroninformation->{'borrowernumber'},'W' );
395 my $nowaiting = scalar @itemswaiting;
396 if ( $nowaiting > 0 ) {
398 $flaginfo{'message'} = "Reserved items available";
399 $flaginfo{'itemlist'} = \@itemswaiting;
400 $flags{'WAITING'} = \%flaginfo;
408 $borrower = &GetMember(%information);
410 Retrieve the first patron record meeting on criteria listed in the
411 C<%information> hash, which should contain one or more
412 pairs of borrowers column names and values, e.g.,
414 $borrower = GetMember(borrowernumber => id);
416 C<&GetBorrower> returns a reference-to-hash whose keys are the fields of
417 the C<borrowers> table in the Koha database.
419 FIXME: GetMember() is used throughout the code as a lookup
420 on a unique key such as the borrowernumber, but this meaning is not
421 enforced in the routine itself.
427 my ( %information ) = @_;
428 if (exists $information{borrowernumber} && !defined $information{borrowernumber}) {
429 #passing mysql's kohaadmin?? Makes no sense as a query
432 my $dbh = C4::Context->dbh;
434 q{SELECT borrowers.*, categories.category_type, categories.description
436 LEFT JOIN categories on borrowers.categorycode=categories.categorycode WHERE };
439 for (keys %information ) {
447 if (defined $information{$_}) {
449 push @values, $information{$_};
452 $select .= "$_ IS NULL";
455 $debug && warn $select, " ",values %information;
456 my $sth = $dbh->prepare("$select");
457 $sth->execute(@values);
458 my $data = $sth->fetchall_arrayref({});
459 #FIXME interface to this routine now allows generation of a result set
460 #so whole array should be returned but bowhere in the current code expects this
468 =head2 IsMemberBlocked
470 my ($block_status, $count) = IsMemberBlocked( $borrowernumber );
472 Returns whether a patron is restricted or has overdue items that may result
473 in a block of circulation privileges.
475 C<$block_status> can have the following values:
477 1 if the patron is currently restricted, in which case
478 C<$count> is the expiration date (9999-12-31 for indefinite)
480 -1 if the patron has overdue items, in which case C<$count> is the number of them
482 0 if the patron has no overdue items or outstanding fine days, in which case C<$count> is 0
484 Existing active restrictions are checked before current overdue items.
488 sub IsMemberBlocked {
489 my $borrowernumber = shift;
490 my $dbh = C4::Context->dbh;
492 my $blockeddate = Koha::Patrons->find( $borrowernumber )->is_debarred;
494 return ( 1, $blockeddate ) if $blockeddate;
496 # if he have late issues
497 my $sth = $dbh->prepare(
498 "SELECT COUNT(*) as latedocs
500 WHERE borrowernumber = ?
501 AND date_due < now()"
503 $sth->execute($borrowernumber);
504 my $latedocs = $sth->fetchrow_hashref->{'latedocs'};
506 return ( -1, $latedocs ) if $latedocs > 0;
511 =head2 GetMemberIssuesAndFines
513 ($overdue_count, $issue_count, $total_fines) = &GetMemberIssuesAndFines($borrowernumber);
515 Returns aggregate data about items borrowed by the patron with the
516 given borrowernumber.
518 C<&GetMemberIssuesAndFines> returns a three-element array. C<$overdue_count> is the
519 number of overdue items the patron currently has borrowed. C<$issue_count> is the
520 number of books the patron currently has borrowed. C<$total_fines> is
521 the total fine currently due by the borrower.
526 sub GetMemberIssuesAndFines {
527 my ( $borrowernumber ) = @_;
528 my $dbh = C4::Context->dbh;
529 my $query = "SELECT COUNT(*) FROM issues WHERE borrowernumber = ?";
531 $debug and warn $query."\n";
532 my $sth = $dbh->prepare($query);
533 $sth->execute($borrowernumber);
534 my $issue_count = $sth->fetchrow_arrayref->[0];
536 $sth = $dbh->prepare(
537 "SELECT COUNT(*) FROM issues
538 WHERE borrowernumber = ?
539 AND date_due < now()"
541 $sth->execute($borrowernumber);
542 my $overdue_count = $sth->fetchrow_arrayref->[0];
544 $sth = $dbh->prepare("SELECT SUM(amountoutstanding) FROM accountlines WHERE borrowernumber = ?");
545 $sth->execute($borrowernumber);
546 my $total_fines = $sth->fetchrow_arrayref->[0];
548 return ($overdue_count, $issue_count, $total_fines);
554 my $success = ModMember(borrowernumber => $borrowernumber,
555 [ field => value ]... );
557 Modify borrower's data. All date fields should ALREADY be in ISO format.
560 true on success, or false on failure
566 # test to know if you must update or not the borrower password
567 if (exists $data{password}) {
568 if ($data{password} eq '****' or $data{password} eq '') {
569 delete $data{password};
571 if ( C4::Context->preference('NorwegianPatronDBEnable') && C4::Context->preference('NorwegianPatronDBEnable') == 1 ) {
572 # Update the hashed PIN in borrower_sync.hashed_pin, before Koha hashes it
573 Koha::NorwegianPatronDB::NLUpdateHashedPIN( $data{'borrowernumber'}, $data{password} );
575 $data{password} = hash_password($data{password});
579 my $old_categorycode = GetBorrowerCategorycode( $data{borrowernumber} );
581 # get only the columns of a borrower
582 my $schema = Koha::Database->new()->schema;
583 my @columns = $schema->source('Borrower')->columns;
584 my $new_borrower = { map { join(' ', @columns) =~ /$_/ ? ( $_ => $data{$_} ) : () } keys(%data) };
585 delete $new_borrower->{flags};
587 $new_borrower->{dateofbirth} ||= undef if exists $new_borrower->{dateofbirth};
588 $new_borrower->{dateenrolled} ||= undef if exists $new_borrower->{dateenrolled};
589 $new_borrower->{dateexpiry} ||= undef if exists $new_borrower->{dateexpiry};
590 $new_borrower->{debarred} ||= undef if exists $new_borrower->{debarred};
591 $new_borrower->{sms_provider_id} ||= undef if exists $new_borrower->{sms_provider_id};
593 my $rs = $schema->resultset('Borrower')->search({
594 borrowernumber => $new_borrower->{borrowernumber},
597 delete $new_borrower->{userid} if exists $new_borrower->{userid} and not $new_borrower->{userid};
599 my $execute_success = $rs->update($new_borrower);
600 if ($execute_success ne '0E0') { # only proceed if the update was a success
601 # If the patron changes to a category with enrollment fee, we add a fee
602 if ( $data{categorycode} and $data{categorycode} ne $old_categorycode ) {
603 if ( C4::Context->preference('FeeOnChangePatronCategory') ) {
604 AddEnrolmentFeeIfNeeded( $data{categorycode}, $data{borrowernumber} );
608 # If NorwegianPatronDBEnable is enabled, we set syncstatus to something that a
609 # cronjob will use for syncing with NL
610 if ( C4::Context->preference('NorwegianPatronDBEnable') && C4::Context->preference('NorwegianPatronDBEnable') == 1 ) {
611 my $borrowersync = Koha::Database->new->schema->resultset('BorrowerSync')->find({
612 'synctype' => 'norwegianpatrondb',
613 'borrowernumber' => $data{'borrowernumber'}
615 # Do not set to "edited" if syncstatus is "new". We need to sync as new before
616 # we can sync as changed. And the "new sync" will pick up all changes since
617 # the patron was created anyway.
618 if ( $borrowersync->syncstatus ne 'new' && $borrowersync->syncstatus ne 'delete' ) {
619 $borrowersync->update( { 'syncstatus' => 'edited' } );
621 # Set the value of 'sync'
622 $borrowersync->update( { 'sync' => $data{'sync'} } );
623 # Try to do the live sync
624 Koha::NorwegianPatronDB::NLSync({ 'borrowernumber' => $data{'borrowernumber'} });
627 logaction("MEMBERS", "MODIFY", $data{'borrowernumber'}, "UPDATE (executed w/ arg: $data{'borrowernumber'})") if C4::Context->preference("BorrowersLog");
629 return $execute_success;
634 $borrowernumber = &AddMember(%borrower);
636 insert new borrower into table
638 (%borrower keys are database columns. Database columns could be
639 different in different versions. Please look into database for correct
642 Returns the borrowernumber upon success
644 Returns as undef upon any db error without further processing
651 my $dbh = C4::Context->dbh;
652 my $schema = Koha::Database->new()->schema;
654 # generate a proper login if none provided
655 $data{'userid'} = Generate_Userid( $data{'borrowernumber'}, $data{'firstname'}, $data{'surname'} )
656 if ( $data{'userid'} eq '' || !Check_Userid( $data{'userid'} ) );
658 # add expiration date if it isn't already there
659 unless ( $data{'dateexpiry'} ) {
660 $data{'dateexpiry'} = GetExpiryDate( $data{'categorycode'}, output_pref( { dt => dt_from_string, dateonly => 1, dateformat => 'iso' } ) );
663 # add enrollment date if it isn't already there
664 unless ( $data{'dateenrolled'} ) {
665 $data{'dateenrolled'} = output_pref( { dt => dt_from_string, dateonly => 1, dateformat => 'iso' } );
668 my $patron_category = $schema->resultset('Category')->find( $data{'categorycode'} );
670 $patron_category->default_privacy() eq 'default' ? 1
671 : $patron_category->default_privacy() eq 'never' ? 2
672 : $patron_category->default_privacy() eq 'forever' ? 0
675 $data{'privacy_guarantor_checkouts'} = 0 unless defined( $data{'privacy_guarantor_checkouts'} );
677 # Make a copy of the plain text password for later use
678 my $plain_text_password = $data{'password'};
680 # create a disabled account if no password provided
681 $data{'password'} = ($data{'password'})? hash_password($data{'password'}) : '!';
683 # we don't want invalid dates in the db (mysql has a bad habit of inserting 0000-00-00
684 $data{'dateofbirth'} = undef if ( not $data{'dateofbirth'} );
685 $data{'debarred'} = undef if ( not $data{'debarred'} );
686 $data{'sms_provider_id'} = undef if ( not $data{'sms_provider_id'} );
688 # get only the columns of Borrower
689 my @columns = $schema->source('Borrower')->columns;
690 my $new_member = { map { join(' ',@columns) =~ /$_/ ? ( $_ => $data{$_} ) : () } keys(%data) } ;
691 $new_member->{checkprevcheckout} ||= 'inherit';
692 delete $new_member->{borrowernumber};
694 my $rs = $schema->resultset('Borrower');
695 $data{borrowernumber} = $rs->create($new_member)->id;
697 # If NorwegianPatronDBEnable is enabled, we set syncstatus to something that a
698 # cronjob will use for syncing with NL
699 if ( exists $data{'borrowernumber'} && C4::Context->preference('NorwegianPatronDBEnable') && C4::Context->preference('NorwegianPatronDBEnable') == 1 ) {
700 Koha::Database->new->schema->resultset('BorrowerSync')->create({
701 'borrowernumber' => $data{'borrowernumber'},
702 'synctype' => 'norwegianpatrondb',
704 'syncstatus' => 'new',
705 'hashed_pin' => Koha::NorwegianPatronDB::NLEncryptPIN( $plain_text_password ),
709 # mysql_insertid is probably bad. not necessarily accurate and mysql-specific at best.
710 logaction("MEMBERS", "CREATE", $data{'borrowernumber'}, "") if C4::Context->preference("BorrowersLog");
712 AddEnrolmentFeeIfNeeded( $data{categorycode}, $data{borrowernumber} );
714 return $data{borrowernumber};
719 my $uniqueness = Check_Userid($userid,$borrowernumber);
721 $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 != '').
723 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.
726 0 for not unique (i.e. this $userid already exists)
727 1 for unique (i.e. this $userid does not exist, or this $userid/$borrowernumber combination already exists)
732 my ( $uid, $borrowernumber ) = @_;
734 return 0 unless ($uid); # userid is a unique column, we should assume NULL is not unique
736 return 0 if ( $uid eq C4::Context->config('user') );
738 my $rs = Koha::Database->new()->schema()->resultset('Borrower');
741 $params->{userid} = $uid;
742 $params->{borrowernumber} = { '!=' => $borrowernumber } if ($borrowernumber);
744 my $count = $rs->count( $params );
746 return $count ? 0 : 1;
749 =head2 Generate_Userid
751 my $newuid = Generate_Userid($borrowernumber, $firstname, $surname);
753 Generate a userid using the $surname and the $firstname (if there is a value in $firstname).
755 $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.
758 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).
762 sub Generate_Userid {
763 my ($borrowernumber, $firstname, $surname) = @_;
766 #The script will "do" the following code and increment the $offset until Check_Userid = 1 (i.e. until $newuid comes back as unique)
768 $firstname =~ s/[[:digit:][:space:][:blank:][:punct:][:cntrl:]]//g;
769 $surname =~ s/[[:digit:][:space:][:blank:][:punct:][:cntrl:]]//g;
770 $newuid = lc(($firstname)? "$firstname.$surname" : $surname);
771 $newuid = unac_string('utf-8',$newuid);
772 $newuid .= $offset unless $offset == 0;
775 } while (!Check_Userid($newuid,$borrowernumber));
780 =head2 fixup_cardnumber
782 Warning: The caller is responsible for locking the members table in write
783 mode, to avoid database corruption.
787 use vars qw( @weightings );
788 my @weightings = ( 8, 4, 6, 3, 5, 2, 1 );
790 sub fixup_cardnumber {
791 my ($cardnumber) = @_;
792 my $autonumber_members = C4::Context->boolean_preference('autoMemberNum') || 0;
794 # Find out whether member numbers should be generated
795 # automatically. Should be either "1" or something else.
796 # Defaults to "0", which is interpreted as "no".
798 # if ($cardnumber !~ /\S/ && $autonumber_members) {
799 ($autonumber_members) or return $cardnumber;
800 my $checkdigit = C4::Context->preference('checkdigit');
801 my $dbh = C4::Context->dbh;
802 if ( $checkdigit and $checkdigit eq 'katipo' ) {
804 # if checkdigit is selected, calculate katipo-style cardnumber.
805 # otherwise, just use the max()
806 # purpose: generate checksum'd member numbers.
807 # We'll assume we just got the max value of digits 2-8 of member #'s
808 # from the database and our job is to increment that by one,
809 # determine the 1st and 9th digits and return the full string.
810 my $sth = $dbh->prepare(
811 "select max(substring(borrowers.cardnumber,2,7)) as new_num from borrowers"
814 my $data = $sth->fetchrow_hashref;
815 $cardnumber = $data->{new_num};
816 if ( !$cardnumber ) { # If DB has no values,
817 $cardnumber = 1000000; # start at 1000000
823 for ( my $i = 0 ; $i < 8 ; $i += 1 ) {
824 # read weightings, left to right, 1 char at a time
825 my $temp1 = $weightings[$i];
827 # sequence left to right, 1 char at a time
828 my $temp2 = substr( $cardnumber, $i, 1 );
830 # mult each char 1-7 by its corresponding weighting
831 $sum += $temp1 * $temp2;
834 my $rem = ( $sum % 11 );
835 $rem = 'X' if $rem == 10;
837 return "V$cardnumber$rem";
840 my $sth = $dbh->prepare(
841 'SELECT MAX( CAST( cardnumber AS SIGNED ) ) FROM borrowers WHERE cardnumber REGEXP "^-?[0-9]+$"'
844 my ($result) = $sth->fetchrow;
847 return $cardnumber; # just here as a fallback/reminder
850 =head2 GetPendingIssues
852 my $issues = &GetPendingIssues(@borrowernumber);
854 Looks up what the patron with the given borrowernumber has borrowed.
856 C<&GetPendingIssues> returns a
857 reference-to-array where each element is a reference-to-hash; the
858 keys are the fields from the C<issues>, C<biblio>, and C<items> tables.
859 The keys include C<biblioitems> fields except marc and marcxml.
863 sub GetPendingIssues {
864 my @borrowernumbers = @_;
866 unless (@borrowernumbers ) { # return a ref_to_array
867 return \@borrowernumbers; # to not cause surprise to caller
870 # Borrowers part of the query
872 for (my $i = 0; $i < @borrowernumbers; $i++) {
873 $bquery .= ' issues.borrowernumber = ?';
874 if ($i < $#borrowernumbers ) {
879 # must avoid biblioitems.* to prevent large marc and marcxml fields from killing performance
880 # FIXME: namespace collision: each table has "timestamp" fields. Which one is "timestamp" ?
881 # FIXME: circ/ciculation.pl tries to sort by timestamp!
882 # FIXME: namespace collision: other collisions possible.
883 # FIXME: most of this data isn't really being used by callers.
890 biblioitems.itemtype,
893 biblioitems.publicationyear,
894 biblioitems.publishercode,
895 biblioitems.volumedate,
896 biblioitems.volumedesc,
901 borrowers.cardnumber,
902 issues.timestamp AS timestamp,
903 issues.renewals AS renewals,
904 issues.borrowernumber AS borrowernumber,
905 items.renewals AS totalrenewals
907 LEFT JOIN items ON items.itemnumber = issues.itemnumber
908 LEFT JOIN biblio ON items.biblionumber = biblio.biblionumber
909 LEFT JOIN biblioitems ON items.biblioitemnumber = biblioitems.biblioitemnumber
910 LEFT JOIN borrowers ON issues.borrowernumber = borrowers.borrowernumber
913 ORDER BY issues.issuedate"
916 my $sth = C4::Context->dbh->prepare($query);
917 $sth->execute(@borrowernumbers);
918 my $data = $sth->fetchall_arrayref({});
919 my $today = dt_from_string;
921 if ($_->{issuedate}) {
922 $_->{issuedate} = dt_from_string($_->{issuedate}, 'sql');
924 $_->{date_due_sql} = $_->{date_due};
925 # FIXME no need to have this value
926 $_->{date_due} or next;
927 $_->{date_due_sql} = $_->{date_due};
928 # FIXME no need to have this value
929 $_->{date_due} = dt_from_string($_->{date_due}, 'sql');
930 if ( DateTime->compare($_->{date_due}, $today) == -1 ) {
939 $issues = &GetAllIssues($borrowernumber, $sortkey, $limit);
941 Looks up what the patron with the given borrowernumber has borrowed,
942 and sorts the results.
944 C<$sortkey> is the name of a field on which to sort the results. This
945 should be the name of a field in the C<issues>, C<biblio>,
946 C<biblioitems>, or C<items> table in the Koha database.
948 C<$limit> is the maximum number of results to return.
950 C<&GetAllIssues> an arrayref, C<$issues>, of hashrefs, the keys of which
951 are the fields from the C<issues>, C<biblio>, C<biblioitems>, and
952 C<items> tables of the Koha database.
958 my ( $borrowernumber, $order, $limit ) = @_;
960 return unless $borrowernumber;
961 $order = 'date_due desc' unless $order;
963 my $dbh = C4::Context->dbh;
965 'SELECT *, issues.timestamp as issuestimestamp, issues.renewals AS renewals,items.renewals AS totalrenewals,items.timestamp AS itemstimestamp
967 LEFT JOIN items on items.itemnumber=issues.itemnumber
968 LEFT JOIN biblio ON items.biblionumber=biblio.biblionumber
969 LEFT JOIN biblioitems ON items.biblioitemnumber=biblioitems.biblioitemnumber
970 WHERE borrowernumber=?
972 SELECT *, old_issues.timestamp as issuestimestamp, old_issues.renewals AS renewals,items.renewals AS totalrenewals,items.timestamp AS itemstimestamp
974 LEFT JOIN items on items.itemnumber=old_issues.itemnumber
975 LEFT JOIN biblio ON items.biblionumber=biblio.biblionumber
976 LEFT JOIN biblioitems ON items.biblioitemnumber=biblioitems.biblioitemnumber
977 WHERE borrowernumber=? AND old_issues.itemnumber IS NOT NULL
980 $query .= " limit $limit";
983 my $sth = $dbh->prepare($query);
984 $sth->execute( $borrowernumber, $borrowernumber );
985 return $sth->fetchall_arrayref( {} );
989 =head2 GetMemberAccountRecords
991 ($total, $acctlines, $count) = &GetMemberAccountRecords($borrowernumber);
993 Looks up accounting data for the patron with the given borrowernumber.
995 C<&GetMemberAccountRecords> returns a three-element array. C<$acctlines> is a
996 reference-to-array, where each element is a reference-to-hash; the
997 keys are the fields of the C<accountlines> table in the Koha database.
998 C<$count> is the number of elements in C<$acctlines>. C<$total> is the
999 total amount outstanding for all of the account lines.
1003 sub GetMemberAccountRecords {
1004 my ($borrowernumber) = @_;
1005 my $dbh = C4::Context->dbh;
1011 WHERE borrowernumber=?);
1012 $strsth.=" ORDER BY accountlines_id desc";
1013 my $sth= $dbh->prepare( $strsth );
1014 $sth->execute( $borrowernumber );
1017 while ( my $data = $sth->fetchrow_hashref ) {
1018 if ( $data->{itemnumber} ) {
1019 my $biblio = GetBiblioFromItemNumber( $data->{itemnumber} );
1020 $data->{biblionumber} = $biblio->{biblionumber};
1021 $data->{title} = $biblio->{title};
1023 $acctlines[$numlines] = $data;
1025 $total += sprintf "%.0f", 1000*$data->{amountoutstanding}; # convert float to integer to avoid round-off errors
1028 return ( $total, \@acctlines,$numlines);
1031 =head2 GetMemberAccountBalance
1033 ($total_balance, $non_issue_balance, $other_charges) = &GetMemberAccountBalance($borrowernumber);
1035 Calculates amount immediately owing by the patron - non-issue charges.
1036 Based on GetMemberAccountRecords.
1037 Charges exempt from non-issue are:
1039 * Rent (rental) if RentalsInNoissuesCharge syspref is set to false
1040 * Manual invoices if ManInvInNoissuesCharge syspref is set to false
1044 sub GetMemberAccountBalance {
1045 my ($borrowernumber) = @_;
1047 my $ACCOUNT_TYPE_LENGTH = 5; # this is plain ridiculous...
1050 push @not_fines, 'Res' unless C4::Context->preference('HoldsInNoissuesCharge');
1051 push @not_fines, 'Rent' unless C4::Context->preference('RentalsInNoissuesCharge');
1052 unless ( C4::Context->preference('ManInvInNoissuesCharge') ) {
1053 my $dbh = C4::Context->dbh;
1054 my $man_inv_types = $dbh->selectcol_arrayref(qq{SELECT authorised_value FROM authorised_values WHERE category = 'MANUAL_INV'});
1055 push @not_fines, map substr($_, 0, $ACCOUNT_TYPE_LENGTH), @$man_inv_types;
1057 my %not_fine = map {$_ => 1} @not_fines;
1059 my ($total, $acctlines) = GetMemberAccountRecords($borrowernumber);
1060 my $other_charges = 0;
1061 foreach (@$acctlines) {
1062 $other_charges += $_->{amountoutstanding} if $not_fine{ substr($_->{accounttype}, 0, $ACCOUNT_TYPE_LENGTH) };
1065 return ( $total, $total - $other_charges, $other_charges);
1068 =head2 GetBorNotifyAcctRecord
1070 ($total, $acctlines, $count) = &GetBorNotifyAcctRecord($params,$notifyid);
1072 Looks up accounting data for the patron with the given borrowernumber per file number.
1074 C<&GetBorNotifyAcctRecord> returns a three-element array. C<$acctlines> is a
1075 reference-to-array, where each element is a reference-to-hash; the
1076 keys are the fields of the C<accountlines> table in the Koha database.
1077 C<$count> is the number of elements in C<$acctlines>. C<$total> is the
1078 total amount outstanding for all of the account lines.
1082 sub GetBorNotifyAcctRecord {
1083 my ( $borrowernumber, $notifyid ) = @_;
1084 my $dbh = C4::Context->dbh;
1087 my $sth = $dbh->prepare(
1090 WHERE borrowernumber=?
1092 AND amountoutstanding != '0'
1093 ORDER BY notify_id,accounttype
1096 $sth->execute( $borrowernumber, $notifyid );
1098 while ( my $data = $sth->fetchrow_hashref ) {
1099 if ( $data->{itemnumber} ) {
1100 my $biblio = GetBiblioFromItemNumber( $data->{itemnumber} );
1101 $data->{biblionumber} = $biblio->{biblionumber};
1102 $data->{title} = $biblio->{title};
1104 $acctlines[$numlines] = $data;
1106 $total += int(100 * $data->{'amountoutstanding'});
1109 return ( $total, \@acctlines, $numlines );
1112 sub checkcardnumber {
1113 my ( $cardnumber, $borrowernumber ) = @_;
1115 # If cardnumber is null, we assume they're allowed.
1116 return 0 unless defined $cardnumber;
1118 my $dbh = C4::Context->dbh;
1119 my $query = "SELECT * FROM borrowers WHERE cardnumber=?";
1120 $query .= " AND borrowernumber <> ?" if ($borrowernumber);
1121 my $sth = $dbh->prepare($query);
1124 ( $borrowernumber ? $borrowernumber : () )
1127 return 1 if $sth->fetchrow_hashref;
1129 my ( $min_length, $max_length ) = get_cardnumber_length();
1131 if length $cardnumber > $max_length
1132 or length $cardnumber < $min_length;
1137 =head2 get_cardnumber_length
1139 my ($min, $max) = C4::Members::get_cardnumber_length()
1141 Returns the minimum and maximum length for patron cardnumbers as
1142 determined by the CardnumberLength system preference, the
1143 BorrowerMandatoryField system preference, and the width of the
1148 sub get_cardnumber_length {
1149 my ( $min, $max ) = ( 0, 16 ); # borrowers.cardnumber is a nullable varchar(16)
1150 $min = 1 if C4::Context->preference('BorrowerMandatoryField') =~ /cardnumber/;
1151 if ( my $cardnumber_length = C4::Context->preference('CardnumberLength') ) {
1152 # Is integer and length match
1153 if ( $cardnumber_length =~ m|^\d+$| ) {
1154 $min = $max = $cardnumber_length
1155 if $cardnumber_length >= $min
1156 and $cardnumber_length <= $max;
1158 # Else assuming it is a range
1159 elsif ( $cardnumber_length =~ m|(\d*),(\d*)| ) {
1160 $min = $1 if $1 and $min < $1;
1161 $max = $2 if $2 and $max > $2;
1165 return ( $min, $max );
1168 =head2 GetFirstValidEmailAddress
1170 $email = GetFirstValidEmailAddress($borrowernumber);
1172 Return the first valid email address for a borrower, given the borrowernumber. For now, the order
1173 is defined as email, emailpro, B_email. Returns the empty string if the borrower has no email
1178 sub GetFirstValidEmailAddress {
1179 my $borrowernumber = shift;
1180 my $dbh = C4::Context->dbh;
1181 my $sth = $dbh->prepare( "SELECT email, emailpro, B_email FROM borrowers where borrowernumber = ? ");
1182 $sth->execute( $borrowernumber );
1183 my $data = $sth->fetchrow_hashref;
1185 if ($data->{'email'}) {
1186 return $data->{'email'};
1187 } elsif ($data->{'emailpro'}) {
1188 return $data->{'emailpro'};
1189 } elsif ($data->{'B_email'}) {
1190 return $data->{'B_email'};
1196 =head2 GetNoticeEmailAddress
1198 $email = GetNoticeEmailAddress($borrowernumber);
1200 Return the email address of borrower used for notices, given the borrowernumber.
1201 Returns the empty string if no email address.
1205 sub GetNoticeEmailAddress {
1206 my $borrowernumber = shift;
1208 my $which_address = C4::Context->preference("AutoEmailPrimaryAddress");
1209 # if syspref is set to 'first valid' (value == OFF), look up email address
1210 if ( $which_address eq 'OFF' ) {
1211 return GetFirstValidEmailAddress($borrowernumber);
1213 # specified email address field
1214 my $dbh = C4::Context->dbh;
1215 my $sth = $dbh->prepare( qq{
1216 SELECT $which_address AS primaryemail
1218 WHERE borrowernumber=?
1220 $sth->execute($borrowernumber);
1221 my $data = $sth->fetchrow_hashref;
1222 return $data->{'primaryemail'} || '';
1225 =head2 GetExpiryDate
1227 $expirydate = GetExpiryDate($categorycode, $dateenrolled);
1229 Calculate expiry date given a categorycode and starting date. Date argument must be in ISO format.
1230 Return date is also in ISO format.
1235 my ( $categorycode, $dateenrolled ) = @_;
1237 if ($categorycode) {
1238 my $dbh = C4::Context->dbh;
1239 my $sth = $dbh->prepare("SELECT enrolmentperiod,enrolmentperioddate FROM categories WHERE categorycode=?");
1240 $sth->execute($categorycode);
1241 $enrolments = $sth->fetchrow_hashref;
1243 # die "GetExpiryDate: for enrollmentperiod $enrolmentperiod (category '$categorycode') starting $dateenrolled.\n";
1244 my @date = split (/-/,$dateenrolled);
1245 if($enrolments->{enrolmentperiod}){
1246 return sprintf("%04d-%02d-%02d", Add_Delta_YM(@date,0,$enrolments->{enrolmentperiod}));
1248 return $enrolments->{enrolmentperioddate};
1252 =head2 GetUpcomingMembershipExpires
1254 my $expires = GetUpcomingMembershipExpires({
1255 branch => $branch, before => $before, after => $after,
1258 $branch is an optional branch code.
1259 $before/$after is an optional number of days before/after the date that
1260 is set by the preference MembershipExpiryDaysNotice.
1261 If the pref would be 14, before 2 and after 3, you will get all expires
1266 sub GetUpcomingMembershipExpires {
1267 my ( $params ) = @_;
1268 my $before = $params->{before} || 0;
1269 my $after = $params->{after} || 0;
1270 my $branch = $params->{branch};
1272 my $dbh = C4::Context->dbh;
1273 my $days = C4::Context->preference("MembershipExpiryDaysNotice") || 0;
1274 my $date1 = dt_from_string->add( days => $days - $before );
1275 my $date2 = dt_from_string->add( days => $days + $after );
1276 $date1= output_pref({ dt => $date1, dateformat => 'iso', dateonly => 1 });
1277 $date2= output_pref({ dt => $date2, dateformat => 'iso', dateonly => 1 });
1280 SELECT borrowers.*, categories.description,
1281 branches.branchname, branches.branchemail FROM borrowers
1282 LEFT JOIN branches USING (branchcode)
1283 LEFT JOIN categories USING (categorycode)
1286 $query.= 'WHERE branchcode=? AND dateexpiry BETWEEN ? AND ?';
1288 $query.= 'WHERE dateexpiry BETWEEN ? AND ?';
1291 my $sth = $dbh->prepare( $query );
1292 my @pars = $branch? ( $branch ): ();
1293 push @pars, $date1, $date2;
1294 $sth->execute( @pars );
1295 my $results = $sth->fetchall_arrayref( {} );
1299 =head2 GetborCatFromCatType
1301 ($codes_arrayref, $labels_hashref) = &GetborCatFromCatType();
1303 Looks up the different types of borrowers in the database. Returns two
1304 elements: a reference-to-array, which lists the borrower category
1305 codes, and a reference-to-hash, which maps the borrower category codes
1306 to category descriptions.
1311 sub GetborCatFromCatType {
1312 my ( $category_type, $action, $no_branch_limit ) = @_;
1314 my $branch_limit = $no_branch_limit
1316 : C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1318 # FIXME - This API seems both limited and dangerous.
1319 my $dbh = C4::Context->dbh;
1322 SELECT DISTINCT categories.categorycode, categories.description
1326 LEFT JOIN categories_branches ON categories.categorycode = categories_branches.categorycode
1329 $request .= " $action ";
1330 $request .= " AND (branchcode = ? OR branchcode IS NULL)" if $branch_limit;
1332 $request .= " WHERE branchcode = ? OR branchcode IS NULL" if $branch_limit;
1334 $request .= " ORDER BY categorycode";
1336 my $sth = $dbh->prepare($request);
1338 $action ? $category_type : (),
1339 $branch_limit ? $branch_limit : ()
1345 while ( my $data = $sth->fetchrow_hashref ) {
1346 push @codes, $data->{'categorycode'};
1347 $labels{ $data->{'categorycode'} } = $data->{'description'};
1350 return ( \@codes, \%labels );
1353 =head2 GetBorrowerCategorycode
1355 $categorycode = &GetBorrowerCategoryCode( $borrowernumber );
1357 Given the borrowernumber, the function returns the corresponding categorycode
1361 sub GetBorrowerCategorycode {
1362 my ( $borrowernumber ) = @_;
1363 my $dbh = C4::Context->dbh;
1364 my $sth = $dbh->prepare( qq{
1367 WHERE borrowernumber = ?
1369 $sth->execute( $borrowernumber );
1370 return $sth->fetchrow;
1373 =head2 GetBorrowercategoryList
1375 $arrayref_hashref = &GetBorrowercategoryList;
1376 If no category code provided, the function returns all the categories.
1380 sub GetBorrowercategoryList {
1381 my $no_branch_limit = @_ ? shift : 0;
1382 my $branch_limit = $no_branch_limit
1384 : C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1385 my $dbh = C4::Context->dbh;
1386 my $query = "SELECT categories.* FROM categories";
1388 LEFT JOIN categories_branches ON categories.categorycode = categories_branches.categorycode
1389 WHERE branchcode = ? OR branchcode IS NULL GROUP BY description
1391 $query .= " ORDER BY description";
1392 my $sth = $dbh->prepare( $query );
1393 $sth->execute( $branch_limit ? $branch_limit : () );
1394 my $data = $sth->fetchall_arrayref( {} );
1397 } # sub getborrowercategory
1401 $dateofbirth,$date = &GetAge($date);
1403 this function return the borrowers age with the value of dateofbirth
1409 my ( $date, $date_ref ) = @_;
1411 if ( not defined $date_ref ) {
1412 $date_ref = sprintf( '%04d-%02d-%02d', Today() );
1415 my ( $year1, $month1, $day1 ) = split /-/, $date;
1416 my ( $year2, $month2, $day2 ) = split /-/, $date_ref;
1418 my $age = $year2 - $year1;
1419 if ( $month1 . $day1 > $month2 . $day2 ) {
1428 $borrower = C4::Members::SetAge($borrower, $datetimeduration);
1429 $borrower = C4::Members::SetAge($borrower, '0015-12-10');
1430 $borrower = C4::Members::SetAge($borrower, $datetimeduration, $datetime_reference);
1432 eval { $borrower = C4::Members::SetAge($borrower, '015-1-10'); };
1433 if ($@) {print $@;} #Catch a bad ISO Date or kill your script!
1435 This function sets the borrower's dateofbirth to match the given age.
1436 Optionally relative to the given $datetime_reference.
1438 @PARAM1 koha.borrowers-object
1439 @PARAM2 DateTime::Duration-object as the desired age
1440 OR a ISO 8601 Date. (To make the API more pleasant)
1441 @PARAM3 DateTime-object as the relative date, defaults to now().
1442 RETURNS The given borrower reference @PARAM1.
1443 DIES If there was an error with the ISO Date handling.
1449 my ( $borrower, $datetimeduration, $datetime_ref ) = @_;
1450 $datetime_ref = DateTime->now() unless $datetime_ref;
1452 if ($datetimeduration && ref $datetimeduration ne 'DateTime::Duration') {
1453 if ($datetimeduration =~ /^(\d{4})-(\d{2})-(\d{2})/) {
1454 $datetimeduration = DateTime::Duration->new(years => $1, months => $2, days => $3);
1457 die "C4::Members::SetAge($borrower, $datetimeduration), datetimeduration not a valid ISO 8601 Date!\n";
1461 my $new_datetime_ref = $datetime_ref->clone();
1462 $new_datetime_ref->subtract_duration( $datetimeduration );
1464 $borrower->{dateofbirth} = $new_datetime_ref->ymd();
1469 =head2 GetSortDetails (OUEST-PROVENCE)
1471 ($lib) = &GetSortDetails($category,$sortvalue);
1473 Returns the authorized value details
1474 C<&$lib>return value of authorized value details
1475 C<&$sortvalue>this is the value of authorized value
1476 C<&$category>this is the value of authorized value category
1480 sub GetSortDetails {
1481 my ( $category, $sortvalue ) = @_;
1482 my $dbh = C4::Context->dbh;
1483 my $query = qq|SELECT lib
1484 FROM authorised_values
1486 AND authorised_value=? |;
1487 my $sth = $dbh->prepare($query);
1488 $sth->execute( $category, $sortvalue );
1489 my $lib = $sth->fetchrow;
1490 return ($lib) if ($lib);
1491 return ($sortvalue) unless ($lib);
1494 =head2 MoveMemberToDeleted
1496 $result = &MoveMemberToDeleted($borrowernumber);
1498 Copy the record from borrowers to deletedborrowers table.
1499 The routine returns 1 for success, undef for failure.
1503 sub MoveMemberToDeleted {
1504 my ($member) = shift or return;
1506 my $schema = Koha::Database->new()->schema();
1507 my $borrowers_rs = $schema->resultset('Borrower');
1508 $borrowers_rs->result_class('DBIx::Class::ResultClass::HashRefInflator');
1509 my $borrower = $borrowers_rs->find($member);
1510 return unless $borrower;
1512 my $deleted = $schema->resultset('Deletedborrower')->create($borrower);
1514 return $deleted ? 1 : undef;
1519 DelMember($borrowernumber);
1521 This function remove directly a borrower whitout writing it on deleteborrower.
1522 + Deletes reserves for the borrower
1527 my $dbh = C4::Context->dbh;
1528 my $borrowernumber = shift;
1529 #warn "in delmember with $borrowernumber";
1530 return unless $borrowernumber; # borrowernumber is mandatory.
1531 # Delete Patron's holds
1532 my @holds = Koha::Holds->search({ borrowernumber => $borrowernumber });
1533 $_->delete for @holds;
1538 WHERE borrowernumber = ?
1540 my $sth = $dbh->prepare($query);
1541 $sth->execute($borrowernumber);
1542 logaction("MEMBERS", "DELETE", $borrowernumber, "") if C4::Context->preference("BorrowersLog");
1546 =head2 HandleDelBorrower
1548 HandleDelBorrower($borrower);
1550 When a member is deleted (DelMember in Members.pm), you should call me first.
1551 This routine deletes/moves lists and entries for the deleted member/borrower.
1552 Lists owned by the borrower are deleted, but entries from the borrower to
1553 other lists are kept.
1557 sub HandleDelBorrower {
1560 my $dbh = C4::Context->dbh;
1562 #Delete all lists and all shares of this borrower
1563 #Consistent with the approach Koha uses on deleting individual lists
1564 #Note that entries in virtualshelfcontents added by this borrower to
1565 #lists of others will be handled by a table constraint: the borrower
1566 #is set to NULL in those entries.
1567 $query="DELETE FROM virtualshelves WHERE owner=?";
1568 $dbh->do($query,undef,($borrower));
1571 #We could handle the above deletes via a constraint too.
1572 #But a new BZ report 11889 has been opened to discuss another approach.
1573 #Instead of deleting we could also disown lists (based on a pref).
1574 #In that way we could save shared and public lists.
1575 #The current table constraints support that idea now.
1576 #This pref should then govern the results of other routines/methods such as
1577 #Koha::Virtualshelf->new->delete too.
1580 =head2 ExtendMemberSubscriptionTo (OUEST-PROVENCE)
1582 $date = ExtendMemberSubscriptionTo($borrowerid, $date);
1584 Extending the subscription to a given date or to the expiry date calculated on ISO date.
1589 sub ExtendMemberSubscriptionTo {
1590 my ( $borrowerid,$date) = @_;
1591 my $dbh = C4::Context->dbh;
1592 my $borrower = GetMember('borrowernumber'=>$borrowerid);
1594 $date = (C4::Context->preference('BorrowerRenewalPeriodBase') eq 'dateexpiry') ?
1595 eval { output_pref( { dt => dt_from_string( $borrower->{'dateexpiry'} ), dateonly => 1, dateformat => 'iso' } ); }
1597 output_pref( { dt => dt_from_string, dateonly => 1, dateformat => 'iso' } );
1598 $date = GetExpiryDate( $borrower->{'categorycode'}, $date );
1600 my $sth = $dbh->do(<<EOF);
1602 SET dateexpiry='$date'
1603 WHERE borrowernumber='$borrowerid'
1606 AddEnrolmentFeeIfNeeded( $borrower->{categorycode}, $borrower->{borrowernumber} );
1608 logaction("MEMBERS", "RENEW", $borrower->{'borrowernumber'}, "Membership renewed")if C4::Context->preference("BorrowersLog");
1609 return $date if ($sth);
1613 =head2 GetHideLostItemsPreference
1615 $hidelostitemspref = &GetHideLostItemsPreference($borrowernumber);
1617 Returns the HideLostItems preference for the patron category of the supplied borrowernumber
1618 C<&$hidelostitemspref>return value of function, 0 or 1
1622 sub GetHideLostItemsPreference {
1623 my ($borrowernumber) = @_;
1624 my $dbh = C4::Context->dbh;
1625 my $query = "SELECT hidelostitems FROM borrowers,categories WHERE borrowers.categorycode = categories.categorycode AND borrowernumber = ?";
1626 my $sth = $dbh->prepare($query);
1627 $sth->execute($borrowernumber);
1628 my $hidelostitems = $sth->fetchrow;
1629 return $hidelostitems;
1632 =head2 GetBorrowersToExpunge
1634 $borrowers = &GetBorrowersToExpunge(
1635 not_borrowed_since => $not_borrowed_since,
1636 expired_before => $expired_before,
1637 category_code => $category_code,
1638 patron_list_id => $patron_list_id,
1639 branchcode => $branchcode
1642 This function get all borrowers based on the given criteria.
1646 sub GetBorrowersToExpunge {
1649 my $filterdate = $params->{'not_borrowed_since'};
1650 my $filterexpiry = $params->{'expired_before'};
1651 my $filtercategory = $params->{'category_code'};
1652 my $filterbranch = $params->{'branchcode'} ||
1653 ((C4::Context->preference('IndependentBranches')
1654 && C4::Context->userenv
1655 && !C4::Context->IsSuperLibrarian()
1656 && C4::Context->userenv->{branch})
1657 ? C4::Context->userenv->{branch}
1659 my $filterpatronlist = $params->{'patron_list_id'};
1661 my $dbh = C4::Context->dbh;
1663 SELECT borrowers.borrowernumber,
1664 MAX(old_issues.timestamp) AS latestissue,
1665 MAX(issues.timestamp) AS currentissue
1667 JOIN categories USING (categorycode)
1671 WHERE guarantorid IS NOT NULL
1672 AND guarantorid <> 0
1673 ) as tmp ON borrowers.borrowernumber=tmp.guarantorid
1674 LEFT JOIN old_issues USING (borrowernumber)
1675 LEFT JOIN issues USING (borrowernumber)|;
1676 if ( $filterpatronlist ){
1677 $query .= q| LEFT JOIN patron_list_patrons USING (borrowernumber)|;
1679 $query .= q| WHERE category_type <> 'S'
1680 AND tmp.guarantorid IS NULL
1683 if ( $filterbranch && $filterbranch ne "" ) {
1684 $query.= " AND borrowers.branchcode = ? ";
1685 push( @query_params, $filterbranch );
1687 if ( $filterexpiry ) {
1688 $query .= " AND dateexpiry < ? ";
1689 push( @query_params, $filterexpiry );
1691 if ( $filtercategory ) {
1692 $query .= " AND categorycode = ? ";
1693 push( @query_params, $filtercategory );
1695 if ( $filterpatronlist ){
1696 $query.=" AND patron_list_id = ? ";
1697 push( @query_params, $filterpatronlist );
1699 $query.=" GROUP BY borrowers.borrowernumber HAVING currentissue IS NULL ";
1700 if ( $filterdate ) {
1701 $query.=" AND ( latestissue < ? OR latestissue IS NULL ) ";
1702 push @query_params,$filterdate;
1704 warn $query if $debug;
1706 my $sth = $dbh->prepare($query);
1707 if (scalar(@query_params)>0){
1708 $sth->execute(@query_params);
1715 while ( my $data = $sth->fetchrow_hashref ) {
1716 push @results, $data;
1721 =head2 GetBorrowersWhoHaveNeverBorrowed
1723 $results = &GetBorrowersWhoHaveNeverBorrowed
1725 This function get all borrowers who have never borrowed.
1727 I<$result> is a ref to an array which all elements are a hasref.
1731 sub GetBorrowersWhoHaveNeverBorrowed {
1732 my $filterbranch = shift ||
1733 ((C4::Context->preference('IndependentBranches')
1734 && C4::Context->userenv
1735 && !C4::Context->IsSuperLibrarian()
1736 && C4::Context->userenv->{branch})
1737 ? C4::Context->userenv->{branch}
1739 my $dbh = C4::Context->dbh;
1741 SELECT borrowers.borrowernumber,max(timestamp) as latestissue
1743 LEFT JOIN issues ON borrowers.borrowernumber = issues.borrowernumber
1744 WHERE issues.borrowernumber IS NULL
1747 if ($filterbranch && $filterbranch ne ""){
1748 $query.=" AND borrowers.branchcode= ?";
1749 push @query_params,$filterbranch;
1751 warn $query if $debug;
1753 my $sth = $dbh->prepare($query);
1754 if (scalar(@query_params)>0){
1755 $sth->execute(@query_params);
1762 while ( my $data = $sth->fetchrow_hashref ) {
1763 push @results, $data;
1768 =head2 GetBorrowersWithIssuesHistoryOlderThan
1770 $results = &GetBorrowersWithIssuesHistoryOlderThan($date)
1772 this function get all borrowers who has an issue history older than I<$date> given on input arg.
1774 I<$result> is a ref to an array which all elements are a hashref.
1775 This hashref is containt the number of time this borrowers has borrowed before I<$date> and the borrowernumber.
1779 sub GetBorrowersWithIssuesHistoryOlderThan {
1780 my $dbh = C4::Context->dbh;
1781 my $date = shift ||POSIX::strftime("%Y-%m-%d",localtime());
1782 my $filterbranch = shift ||
1783 ((C4::Context->preference('IndependentBranches')
1784 && C4::Context->userenv
1785 && !C4::Context->IsSuperLibrarian()
1786 && C4::Context->userenv->{branch})
1787 ? C4::Context->userenv->{branch}
1790 SELECT count(borrowernumber) as n,borrowernumber
1792 WHERE returndate < ?
1793 AND borrowernumber IS NOT NULL
1796 push @query_params, $date;
1798 $query.=" AND branchcode = ?";
1799 push @query_params, $filterbranch;
1801 $query.=" GROUP BY borrowernumber ";
1802 warn $query if $debug;
1803 my $sth = $dbh->prepare($query);
1804 $sth->execute(@query_params);
1807 while ( my $data = $sth->fetchrow_hashref ) {
1808 push @results, $data;
1815 IssueSlip($branchcode, $borrowernumber, $quickslip)
1817 Returns letter hash ( see C4::Letters::GetPreparedLetter )
1819 $quickslip is boolean, to indicate whether we want a quick slip
1821 IssueSlip populates ISSUESLIP and ISSUEQSLIP, and will make the following expansions:
1857 NOTE: Not all table fields are available, pleasee see GetPendingIssues for a list of available fields.
1862 my ($branch, $borrowernumber, $quickslip) = @_;
1864 # FIXME Check callers before removing this statement
1865 #return unless $borrowernumber;
1867 my @issues = @{ GetPendingIssues($borrowernumber) };
1869 for my $issue (@issues) {
1870 $issue->{date_due} = $issue->{date_due_sql};
1872 my $today = output_pref({ dt => dt_from_string, dateformat => 'iso', dateonly => 1 });
1873 if ( substr( $issue->{issuedate}, 0, 10 ) eq $today
1874 or substr( $issue->{lastreneweddate}, 0, 10 ) eq $today ) {
1880 # Sort on timestamp then on issuedate (useful for tests and could be if modified in a batch
1882 my $s = $b->{timestamp} <=> $a->{timestamp};
1884 $b->{issuedate} <=> $a->{issuedate} : $s;
1887 my ($letter_code, %repeat);
1889 $letter_code = 'ISSUEQSLIP';
1891 'checkedout' => [ map {
1894 'biblioitems' => $_,
1896 }, grep { $_->{'now'} } @issues ],
1900 $letter_code = 'ISSUESLIP';
1902 'checkedout' => [ map {
1905 'biblioitems' => $_,
1907 }, grep { !$_->{'overdue'} } @issues ],
1909 'overdue' => [ map {
1912 'biblioitems' => $_,
1914 }, grep { $_->{'overdue'} } @issues ],
1917 $_->{'timestamp'} = $_->{'newdate'};
1919 } @{ GetNewsToDisplay("slip",$branch) } ],
1923 return C4::Letters::GetPreparedLetter (
1924 module => 'circulation',
1925 letter_code => $letter_code,
1926 branchcode => $branch,
1928 'branches' => $branch,
1929 'borrowers' => $borrowernumber,
1935 =head2 GetBorrowersWithEmail
1937 ([$borrnum,$userid], ...) = GetBorrowersWithEmail('me@example.com');
1939 This gets a list of users and their basic details from their email address.
1940 As it's possible for multiple user to have the same email address, it provides
1941 you with all of them. If there is no userid for the user, there will be an
1942 C<undef> there. An empty list will be returned if there are no matches.
1946 sub GetBorrowersWithEmail {
1949 my $dbh = C4::Context->dbh;
1951 my $query = "SELECT borrowernumber, userid FROM borrowers WHERE email=?";
1952 my $sth=$dbh->prepare($query);
1953 $sth->execute($email);
1955 while (my $ref = $sth->fetch) {
1958 die "Failure searching for borrowers by email address: $sth->errstr" if $sth->err;
1962 =head2 AddMember_Opac
1966 sub AddMember_Opac {
1967 my ( %borrower ) = @_;
1969 $borrower{'categorycode'} //= C4::Context->preference('PatronSelfRegistrationDefaultCategory');
1970 if (not defined $borrower{'password'}){
1971 my $sr = new String::Random;
1972 $sr->{'A'} = [ 'A'..'Z', 'a'..'z' ];
1973 my $password = $sr->randpattern("AAAAAAAAAA");
1974 $borrower{'password'} = $password;
1977 $borrower{'cardnumber'} = fixup_cardnumber( $borrower{'cardnumber'} );
1979 my $borrowernumber = AddMember(%borrower);
1981 return ( $borrowernumber, $borrower{'password'} );
1984 =head2 AddEnrolmentFeeIfNeeded
1986 AddEnrolmentFeeIfNeeded( $borrower->{categorycode}, $borrower->{borrowernumber} );
1988 Add enrolment fee for a patron if needed.
1992 sub AddEnrolmentFeeIfNeeded {
1993 my ( $categorycode, $borrowernumber ) = @_;
1994 # check for enrollment fee & add it if needed
1995 my $dbh = C4::Context->dbh;
1996 my $sth = $dbh->prepare(q{
1999 WHERE categorycode=?
2001 $sth->execute( $categorycode );
2003 warn sprintf('Database returned the following error: %s', $sth->errstr);
2006 my ($enrolmentfee) = $sth->fetchrow;
2007 if ($enrolmentfee && $enrolmentfee > 0) {
2008 # insert fee in patron debts
2009 C4::Accounts::manualinvoice( $borrowernumber, '', '', 'A', $enrolmentfee );
2018 my ( $borrowernumber ) = @_;
2020 my $sql = "SELECT COUNT(*) FROM issues WHERE date_due < NOW() AND borrowernumber = ?";
2021 my $sth = C4::Context->dbh->prepare( $sql );
2022 $sth->execute( $borrowernumber );
2023 my ( $count ) = $sth->fetchrow_array();
2028 =head2 DeleteExpiredOpacRegistrations
2030 Delete accounts that haven't been upgraded from the 'temporary' category
2031 Returns the number of removed patrons
2035 sub DeleteExpiredOpacRegistrations {
2037 my $delay = C4::Context->preference('PatronSelfRegistrationExpireTemporaryAccountsDelay');
2038 my $category_code = C4::Context->preference('PatronSelfRegistrationDefaultCategory');
2040 return 0 if not $category_code or not defined $delay or $delay eq q||;
2043 SELECT borrowernumber
2045 WHERE categorycode = ? AND DATEDIFF( NOW(), dateenrolled ) > ? |;
2047 my $dbh = C4::Context->dbh;
2048 my $sth = $dbh->prepare($query);
2049 $sth->execute( $category_code, $delay );
2051 while ( my ($borrowernumber) = $sth->fetchrow_array() ) {
2052 DelMember($borrowernumber);
2058 =head2 DeleteUnverifiedOpacRegistrations
2060 Delete all unverified self registrations in borrower_modifications,
2061 older than the specified number of days.
2065 sub DeleteUnverifiedOpacRegistrations {
2067 my $dbh = C4::Context->dbh;
2069 DELETE FROM borrower_modifications
2070 WHERE borrowernumber = 0 AND DATEDIFF( NOW(), timestamp ) > ?|;
2071 my $cnt=$dbh->do($sql, undef, ($days) );
2072 return $cnt eq '0E0'? 0: $cnt;
2075 sub GetOverduesForPatron {
2076 my ( $borrowernumber ) = @_;
2080 FROM issues, items, biblio, biblioitems
2081 WHERE items.itemnumber=issues.itemnumber
2082 AND biblio.biblionumber = items.biblionumber
2083 AND biblio.biblionumber = biblioitems.biblionumber
2084 AND issues.borrowernumber = ?
2085 AND date_due < NOW()
2088 my $sth = C4::Context->dbh->prepare( $sql );
2089 $sth->execute( $borrowernumber );
2091 return $sth->fetchall_arrayref({});
2094 END { } # module clean-up code here (global destructor)