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
76 &GetHideLostItemsPreference
79 &GetMemberAccountRecords
80 &GetBorNotifyAcctRecord
84 GetBorrowerCategorycode
85 &GetBorrowercategoryList
87 &GetBorrowersToExpunge
88 &GetBorrowersWhoHaveNeverBorrowed
89 &GetBorrowersWithIssuesHistoryOlderThan
92 &GetUpcomingMembershipExpires
117 &ExtendMemberSubscriptionTo
133 C4::Members - Perl Module containing convenience functions for member handling
141 This module contains routines for adding, modifying and deleting members/patrons/borrowers
145 =head2 GetMemberDetails
147 ($borrower) = &GetMemberDetails($borrowernumber, $cardnumber);
149 Looks up a patron and returns information about him or her. If
150 C<$borrowernumber> is true (nonzero), C<&GetMemberDetails> looks
151 up the borrower by number; otherwise, it looks up the borrower by card
154 C<$borrower> is a reference-to-hash whose keys are the fields of the
155 borrowers table in the Koha database. In addition,
156 C<$borrower-E<gt>{flags}> is a hash giving more detailed information
157 about the patron. Its keys act as flags :
159 if $borrower->{flags}->{LOST} {
160 # Patron's card was reported lost
163 If the state of a flag means that the patron should not be
164 allowed to borrow any more books, then it will have a C<noissues> key
167 See patronflags for more details.
169 C<$borrower-E<gt>{authflags}> is a hash giving more detailed information
170 about the top-level permissions flags set for the borrower. For example,
171 if a user has the "editcatalogue" permission,
172 C<$borrower-E<gt>{authflags}-E<gt>{editcatalogue}> will exist and have
177 sub GetMemberDetails {
178 my ( $borrowernumber, $cardnumber ) = @_;
179 my $dbh = C4::Context->dbh;
182 if ($borrowernumber) {
183 $sth = $dbh->prepare("
186 categories.description,
187 categories.BlockExpiredPatronOpacActions,
191 LEFT JOIN categories ON borrowers.categorycode=categories.categorycode
192 WHERE borrowernumber = ?
194 $sth->execute($borrowernumber);
196 elsif ($cardnumber) {
197 $sth = $dbh->prepare("
200 categories.description,
201 categories.BlockExpiredPatronOpacActions,
205 LEFT JOIN categories ON borrowers.categorycode = categories.categorycode
208 $sth->execute($cardnumber);
213 my $borrower = $sth->fetchrow_hashref;
214 return unless $borrower;
215 my ($amount) = GetMemberAccountRecords($borrower->{borrowernumber});
216 $borrower->{'amountoutstanding'} = $amount;
217 # FIXME - patronflags calls GetMemberAccountRecords... just have patronflags return $amount
218 my $flags = patronflags( $borrower);
221 $sth = $dbh->prepare("select bit,flag from userflags");
223 while ( my ( $bit, $flag ) = $sth->fetchrow ) {
224 if ( $borrower->{'flags'} && $borrower->{'flags'} & 2**$bit ) {
225 $accessflagshash->{$flag} = 1;
228 $borrower->{'flags'} = $flags;
229 $borrower->{'authflags'} = $accessflagshash;
231 # Handle setting the true behavior for BlockExpiredPatronOpacActions
232 $borrower->{'BlockExpiredPatronOpacActions'} =
233 C4::Context->preference('BlockExpiredPatronOpacActions')
234 if ( $borrower->{'BlockExpiredPatronOpacActions'} == -1 );
236 $borrower->{'is_expired'} = 0;
237 $borrower->{'is_expired'} = 1 if
238 defined($borrower->{dateexpiry}) &&
239 $borrower->{'dateexpiry'} ne '0000-00-00' &&
240 Date_to_Days( Today() ) >
241 Date_to_Days( split /-/, $borrower->{'dateexpiry'} );
243 return ($borrower); #, $flags, $accessflagshash);
248 $flags = &patronflags($patron);
250 This function is not exported.
252 The following will be set where applicable:
253 $flags->{CHARGES}->{amount} Amount of debt
254 $flags->{CHARGES}->{noissues} Set if debt amount >$5.00 (or syspref noissuescharge)
255 $flags->{CHARGES}->{message} Message -- deprecated
257 $flags->{CREDITS}->{amount} Amount of credit
258 $flags->{CREDITS}->{message} Message -- deprecated
260 $flags->{ GNA } Patron has no valid address
261 $flags->{ GNA }->{noissues} Set for each GNA
262 $flags->{ GNA }->{message} "Borrower has no valid address" -- deprecated
264 $flags->{ LOST } Patron's card reported lost
265 $flags->{ LOST }->{noissues} Set for each LOST
266 $flags->{ LOST }->{message} Message -- deprecated
268 $flags->{DBARRED} Set if patron debarred, no access
269 $flags->{DBARRED}->{noissues} Set for each DBARRED
270 $flags->{DBARRED}->{message} Message -- deprecated
273 $flags->{ NOTES }->{message} The note itself. NOT deprecated
275 $flags->{ ODUES } Set if patron has overdue books.
276 $flags->{ ODUES }->{message} "Yes" -- deprecated
277 $flags->{ ODUES }->{itemlist} ref-to-array: list of overdue books
278 $flags->{ ODUES }->{itemlisttext} Text list of overdue items -- deprecated
280 $flags->{WAITING} Set if any of patron's reserves are available
281 $flags->{WAITING}->{message} Message -- deprecated
282 $flags->{WAITING}->{itemlist} ref-to-array: list of available items
286 =item C<$flags-E<gt>{ODUES}-E<gt>{itemlist}> is a reference-to-array listing the
287 overdue items. Its elements are references-to-hash, each describing an
288 overdue item. The keys are selected fields from the issues, biblio,
289 biblioitems, and items tables of the Koha database.
291 =item C<$flags-E<gt>{ODUES}-E<gt>{itemlisttext}> is a string giving a text listing of
292 the overdue items, one per line. Deprecated.
294 =item C<$flags-E<gt>{WAITING}-E<gt>{itemlist}> is a reference-to-array listing the
295 available items. Each element is a reference-to-hash whose keys are
296 fields from the reserves table of the Koha database.
300 All the "message" fields that include language generated in this function are deprecated,
301 because such strings belong properly in the display layer.
303 The "message" field that comes from the DB is OK.
307 # TODO: use {anonymous => hashes} instead of a dozen %flaginfo
308 # FIXME rename this function.
311 my ( $patroninformation) = @_;
312 my $dbh=C4::Context->dbh;
313 my ($balance, $owing) = GetMemberAccountBalance( $patroninformation->{'borrowernumber'});
316 my $noissuescharge = C4::Context->preference("noissuescharge") || 5;
317 $flaginfo{'message'} = sprintf 'Patron owes %.02f', $owing;
318 $flaginfo{'amount'} = sprintf "%.02f", $owing;
319 if ( $owing > $noissuescharge && !C4::Context->preference("AllowFineOverride") ) {
320 $flaginfo{'noissues'} = 1;
322 $flags{'CHARGES'} = \%flaginfo;
324 elsif ( $balance < 0 ) {
326 $flaginfo{'message'} = sprintf 'Patron has credit of %.02f', -$balance;
327 $flaginfo{'amount'} = sprintf "%.02f", $balance;
328 $flags{'CREDITS'} = \%flaginfo;
331 # Check the debt of the guarntees of this patron
332 my $no_issues_charge_guarantees = C4::Context->preference("NoIssuesChargeGuarantees");
333 $no_issues_charge_guarantees = undef unless looks_like_number( $no_issues_charge_guarantees );
334 if ( defined $no_issues_charge_guarantees ) {
335 my $p = Koha::Patrons->find( $patroninformation->{borrowernumber} );
336 my @guarantees = $p->guarantees();
337 my $guarantees_non_issues_charges;
338 foreach my $g ( @guarantees ) {
339 my ( $b, $n, $o ) = C4::Members::GetMemberAccountBalance( $g->id );
340 $guarantees_non_issues_charges += $n;
343 if ( $guarantees_non_issues_charges > $no_issues_charge_guarantees ) {
345 $flaginfo{'message'} = sprintf 'patron guarantees owe %.02f', $guarantees_non_issues_charges;
346 $flaginfo{'amount'} = $guarantees_non_issues_charges;
347 $flaginfo{'noissues'} = 1 unless C4::Context->preference("allowfineoverride");
348 $flags{'CHARGES_GUARANTEES'} = \%flaginfo;
352 if ( $patroninformation->{'gonenoaddress'}
353 && $patroninformation->{'gonenoaddress'} == 1 )
356 $flaginfo{'message'} = 'Borrower has no valid address.';
357 $flaginfo{'noissues'} = 1;
358 $flags{'GNA'} = \%flaginfo;
360 if ( $patroninformation->{'lost'} && $patroninformation->{'lost'} == 1 ) {
362 $flaginfo{'message'} = 'Borrower\'s card reported lost.';
363 $flaginfo{'noissues'} = 1;
364 $flags{'LOST'} = \%flaginfo;
366 if ( $patroninformation->{'debarred'} && check_date( split( /-/, $patroninformation->{'debarred'} ) ) ) {
367 if ( Date_to_Days(Date::Calc::Today) < Date_to_Days( split( /-/, $patroninformation->{'debarred'} ) ) ) {
369 $flaginfo{'debarredcomment'} = $patroninformation->{'debarredcomment'};
370 $flaginfo{'message'} = $patroninformation->{'debarredcomment'};
371 $flaginfo{'noissues'} = 1;
372 $flaginfo{'dateend'} = $patroninformation->{'debarred'};
373 $flags{'DBARRED'} = \%flaginfo;
376 if ( $patroninformation->{'borrowernotes'}
377 && $patroninformation->{'borrowernotes'} )
380 $flaginfo{'message'} = $patroninformation->{'borrowernotes'};
381 $flags{'NOTES'} = \%flaginfo;
383 my ( $odues, $itemsoverdue ) = C4::Overdues::checkoverdues($patroninformation->{'borrowernumber'});
384 if ( $odues && $odues > 0 ) {
386 $flaginfo{'message'} = "Yes";
387 $flaginfo{'itemlist'} = $itemsoverdue;
388 foreach ( sort { $a->{'date_due'} cmp $b->{'date_due'} }
391 $flaginfo{'itemlisttext'} .=
392 "$_->{'date_due'} $_->{'barcode'} $_->{'title'} \n"; # newline is display layer
394 $flags{'ODUES'} = \%flaginfo;
396 my @itemswaiting = C4::Reserves::GetReservesFromBorrowernumber( $patroninformation->{'borrowernumber'},'W' );
397 my $nowaiting = scalar @itemswaiting;
398 if ( $nowaiting > 0 ) {
400 $flaginfo{'message'} = "Reserved items available";
401 $flaginfo{'itemlist'} = \@itemswaiting;
402 $flags{'WAITING'} = \%flaginfo;
410 $borrower = &GetMember(%information);
412 Retrieve the first patron record meeting on criteria listed in the
413 C<%information> hash, which should contain one or more
414 pairs of borrowers column names and values, e.g.,
416 $borrower = GetMember(borrowernumber => id);
418 C<&GetBorrower> returns a reference-to-hash whose keys are the fields of
419 the C<borrowers> table in the Koha database.
421 FIXME: GetMember() is used throughout the code as a lookup
422 on a unique key such as the borrowernumber, but this meaning is not
423 enforced in the routine itself.
429 my ( %information ) = @_;
430 if (exists $information{borrowernumber} && !defined $information{borrowernumber}) {
431 #passing mysql's kohaadmin?? Makes no sense as a query
434 my $dbh = C4::Context->dbh;
436 q{SELECT borrowers.*, categories.category_type, categories.description
438 LEFT JOIN categories on borrowers.categorycode=categories.categorycode WHERE };
441 for (keys %information ) {
449 if (defined $information{$_}) {
451 push @values, $information{$_};
454 $select .= "$_ IS NULL";
457 $debug && warn $select, " ",values %information;
458 my $sth = $dbh->prepare("$select");
459 $sth->execute(@values);
460 my $data = $sth->fetchall_arrayref({});
461 #FIXME interface to this routine now allows generation of a result set
462 #so whole array should be returned but bowhere in the current code expects this
470 =head2 IsMemberBlocked
472 my ($block_status, $count) = IsMemberBlocked( $borrowernumber );
474 Returns whether a patron is restricted or has overdue items that may result
475 in a block of circulation privileges.
477 C<$block_status> can have the following values:
479 1 if the patron is currently restricted, in which case
480 C<$count> is the expiration date (9999-12-31 for indefinite)
482 -1 if the patron has overdue items, in which case C<$count> is the number of them
484 0 if the patron has no overdue items or outstanding fine days, in which case C<$count> is 0
486 Existing active restrictions are checked before current overdue items.
490 sub IsMemberBlocked {
491 my $borrowernumber = shift;
492 my $dbh = C4::Context->dbh;
494 my $blockeddate = Koha::Patrons->find( $borrowernumber )->is_debarred;
496 return ( 1, $blockeddate ) if $blockeddate;
498 # if he have late issues
499 my $sth = $dbh->prepare(
500 "SELECT COUNT(*) as latedocs
502 WHERE borrowernumber = ?
503 AND date_due < now()"
505 $sth->execute($borrowernumber);
506 my $latedocs = $sth->fetchrow_hashref->{'latedocs'};
508 return ( -1, $latedocs ) if $latedocs > 0;
513 =head2 GetMemberIssuesAndFines
515 ($overdue_count, $issue_count, $total_fines) = &GetMemberIssuesAndFines($borrowernumber);
517 Returns aggregate data about items borrowed by the patron with the
518 given borrowernumber.
520 C<&GetMemberIssuesAndFines> returns a three-element array. C<$overdue_count> is the
521 number of overdue items the patron currently has borrowed. C<$issue_count> is the
522 number of books the patron currently has borrowed. C<$total_fines> is
523 the total fine currently due by the borrower.
528 sub GetMemberIssuesAndFines {
529 my ( $borrowernumber ) = @_;
530 my $dbh = C4::Context->dbh;
531 my $query = "SELECT COUNT(*) FROM issues WHERE borrowernumber = ?";
533 $debug and warn $query."\n";
534 my $sth = $dbh->prepare($query);
535 $sth->execute($borrowernumber);
536 my $issue_count = $sth->fetchrow_arrayref->[0];
538 $sth = $dbh->prepare(
539 "SELECT COUNT(*) FROM issues
540 WHERE borrowernumber = ?
541 AND date_due < now()"
543 $sth->execute($borrowernumber);
544 my $overdue_count = $sth->fetchrow_arrayref->[0];
546 $sth = $dbh->prepare("SELECT SUM(amountoutstanding) FROM accountlines WHERE borrowernumber = ?");
547 $sth->execute($borrowernumber);
548 my $total_fines = $sth->fetchrow_arrayref->[0];
550 return ($overdue_count, $issue_count, $total_fines);
556 my $success = ModMember(borrowernumber => $borrowernumber,
557 [ field => value ]... );
559 Modify borrower's data. All date fields should ALREADY be in ISO format.
562 true on success, or false on failure
568 # test to know if you must update or not the borrower password
569 if (exists $data{password}) {
570 if ($data{password} eq '****' or $data{password} eq '') {
571 delete $data{password};
573 if ( C4::Context->preference('NorwegianPatronDBEnable') && C4::Context->preference('NorwegianPatronDBEnable') == 1 ) {
574 # Update the hashed PIN in borrower_sync.hashed_pin, before Koha hashes it
575 Koha::NorwegianPatronDB::NLUpdateHashedPIN( $data{'borrowernumber'}, $data{password} );
577 $data{password} = hash_password($data{password});
581 my $old_categorycode = GetBorrowerCategorycode( $data{borrowernumber} );
583 # get only the columns of a borrower
584 my $schema = Koha::Database->new()->schema;
585 my @columns = $schema->source('Borrower')->columns;
586 my $new_borrower = { map { join(' ', @columns) =~ /$_/ ? ( $_ => $data{$_} ) : () } keys(%data) };
587 delete $new_borrower->{flags};
589 $new_borrower->{dateofbirth} ||= undef if exists $new_borrower->{dateofbirth};
590 $new_borrower->{dateenrolled} ||= undef if exists $new_borrower->{dateenrolled};
591 $new_borrower->{dateexpiry} ||= undef if exists $new_borrower->{dateexpiry};
592 $new_borrower->{debarred} ||= undef if exists $new_borrower->{debarred};
593 $new_borrower->{sms_provider_id} ||= undef if exists $new_borrower->{sms_provider_id};
595 my $rs = $schema->resultset('Borrower')->search({
596 borrowernumber => $new_borrower->{borrowernumber},
599 delete $new_borrower->{userid} if exists $new_borrower->{userid} and not $new_borrower->{userid};
601 my $execute_success = $rs->update($new_borrower);
602 if ($execute_success ne '0E0') { # only proceed if the update was a success
603 # If the patron changes to a category with enrollment fee, we add a fee
604 if ( $data{categorycode} and $data{categorycode} ne $old_categorycode ) {
605 if ( C4::Context->preference('FeeOnChangePatronCategory') ) {
606 AddEnrolmentFeeIfNeeded( $data{categorycode}, $data{borrowernumber} );
610 # If NorwegianPatronDBEnable is enabled, we set syncstatus to something that a
611 # cronjob will use for syncing with NL
612 if ( C4::Context->preference('NorwegianPatronDBEnable') && C4::Context->preference('NorwegianPatronDBEnable') == 1 ) {
613 my $borrowersync = Koha::Database->new->schema->resultset('BorrowerSync')->find({
614 'synctype' => 'norwegianpatrondb',
615 'borrowernumber' => $data{'borrowernumber'}
617 # Do not set to "edited" if syncstatus is "new". We need to sync as new before
618 # we can sync as changed. And the "new sync" will pick up all changes since
619 # the patron was created anyway.
620 if ( $borrowersync->syncstatus ne 'new' && $borrowersync->syncstatus ne 'delete' ) {
621 $borrowersync->update( { 'syncstatus' => 'edited' } );
623 # Set the value of 'sync'
624 $borrowersync->update( { 'sync' => $data{'sync'} } );
625 # Try to do the live sync
626 Koha::NorwegianPatronDB::NLSync({ 'borrowernumber' => $data{'borrowernumber'} });
629 logaction("MEMBERS", "MODIFY", $data{'borrowernumber'}, "UPDATE (executed w/ arg: $data{'borrowernumber'})") if C4::Context->preference("BorrowersLog");
631 return $execute_success;
636 $borrowernumber = &AddMember(%borrower);
638 insert new borrower into table
640 (%borrower keys are database columns. Database columns could be
641 different in different versions. Please look into database for correct
644 Returns the borrowernumber upon success
646 Returns as undef upon any db error without further processing
653 my $dbh = C4::Context->dbh;
654 my $schema = Koha::Database->new()->schema;
656 # generate a proper login if none provided
657 $data{'userid'} = Generate_Userid( $data{'borrowernumber'}, $data{'firstname'}, $data{'surname'} )
658 if ( $data{'userid'} eq '' || !Check_Userid( $data{'userid'} ) );
660 # add expiration date if it isn't already there
661 unless ( $data{'dateexpiry'} ) {
662 $data{'dateexpiry'} = GetExpiryDate( $data{'categorycode'}, output_pref( { dt => dt_from_string, dateonly => 1, dateformat => 'iso' } ) );
665 # add enrollment date if it isn't already there
666 unless ( $data{'dateenrolled'} ) {
667 $data{'dateenrolled'} = output_pref( { dt => dt_from_string, dateonly => 1, dateformat => 'iso' } );
670 my $patron_category = $schema->resultset('Category')->find( $data{'categorycode'} );
672 $patron_category->default_privacy() eq 'default' ? 1
673 : $patron_category->default_privacy() eq 'never' ? 2
674 : $patron_category->default_privacy() eq 'forever' ? 0
677 $data{'privacy_guarantor_checkouts'} = 0 unless defined( $data{'privacy_guarantor_checkouts'} );
679 # Make a copy of the plain text password for later use
680 my $plain_text_password = $data{'password'};
682 # create a disabled account if no password provided
683 $data{'password'} = ($data{'password'})? hash_password($data{'password'}) : '!';
685 # we don't want invalid dates in the db (mysql has a bad habit of inserting 0000-00-00
686 $data{'dateofbirth'} = undef if ( not $data{'dateofbirth'} );
687 $data{'debarred'} = undef if ( not $data{'debarred'} );
688 $data{'sms_provider_id'} = undef if ( not $data{'sms_provider_id'} );
690 # get only the columns of Borrower
691 my @columns = $schema->source('Borrower')->columns;
692 my $new_member = { map { join(' ',@columns) =~ /$_/ ? ( $_ => $data{$_} ) : () } keys(%data) } ;
693 $new_member->{checkprevcheckout} ||= 'inherit';
694 delete $new_member->{borrowernumber};
696 my $rs = $schema->resultset('Borrower');
697 $data{borrowernumber} = $rs->create($new_member)->id;
699 # If NorwegianPatronDBEnable is enabled, we set syncstatus to something that a
700 # cronjob will use for syncing with NL
701 if ( exists $data{'borrowernumber'} && C4::Context->preference('NorwegianPatronDBEnable') && C4::Context->preference('NorwegianPatronDBEnable') == 1 ) {
702 Koha::Database->new->schema->resultset('BorrowerSync')->create({
703 'borrowernumber' => $data{'borrowernumber'},
704 'synctype' => 'norwegianpatrondb',
706 'syncstatus' => 'new',
707 'hashed_pin' => Koha::NorwegianPatronDB::NLEncryptPIN( $plain_text_password ),
711 # mysql_insertid is probably bad. not necessarily accurate and mysql-specific at best.
712 logaction("MEMBERS", "CREATE", $data{'borrowernumber'}, "") if C4::Context->preference("BorrowersLog");
714 AddEnrolmentFeeIfNeeded( $data{categorycode}, $data{borrowernumber} );
716 return $data{borrowernumber};
721 my $uniqueness = Check_Userid($userid,$borrowernumber);
723 $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 != '').
725 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.
728 0 for not unique (i.e. this $userid already exists)
729 1 for unique (i.e. this $userid does not exist, or this $userid/$borrowernumber combination already exists)
734 my ( $uid, $borrowernumber ) = @_;
736 return 0 unless ($uid); # userid is a unique column, we should assume NULL is not unique
738 return 0 if ( $uid eq C4::Context->config('user') );
740 my $rs = Koha::Database->new()->schema()->resultset('Borrower');
743 $params->{userid} = $uid;
744 $params->{borrowernumber} = { '!=' => $borrowernumber } if ($borrowernumber);
746 my $count = $rs->count( $params );
748 return $count ? 0 : 1;
751 =head2 Generate_Userid
753 my $newuid = Generate_Userid($borrowernumber, $firstname, $surname);
755 Generate a userid using the $surname and the $firstname (if there is a value in $firstname).
757 $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.
760 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).
764 sub Generate_Userid {
765 my ($borrowernumber, $firstname, $surname) = @_;
768 #The script will "do" the following code and increment the $offset until Check_Userid = 1 (i.e. until $newuid comes back as unique)
770 $firstname =~ s/[[:digit:][:space:][:blank:][:punct:][:cntrl:]]//g;
771 $surname =~ s/[[:digit:][:space:][:blank:][:punct:][:cntrl:]]//g;
772 $newuid = lc(($firstname)? "$firstname.$surname" : $surname);
773 $newuid = unac_string('utf-8',$newuid);
774 $newuid .= $offset unless $offset == 0;
777 } while (!Check_Userid($newuid,$borrowernumber));
782 =head2 fixup_cardnumber
784 Warning: The caller is responsible for locking the members table in write
785 mode, to avoid database corruption.
789 use vars qw( @weightings );
790 my @weightings = ( 8, 4, 6, 3, 5, 2, 1 );
792 sub fixup_cardnumber {
793 my ($cardnumber) = @_;
794 my $autonumber_members = C4::Context->boolean_preference('autoMemberNum') || 0;
796 # Find out whether member numbers should be generated
797 # automatically. Should be either "1" or something else.
798 # Defaults to "0", which is interpreted as "no".
800 # if ($cardnumber !~ /\S/ && $autonumber_members) {
801 ($autonumber_members) or return $cardnumber;
802 my $checkdigit = C4::Context->preference('checkdigit');
803 my $dbh = C4::Context->dbh;
804 if ( $checkdigit and $checkdigit eq 'katipo' ) {
806 # if checkdigit is selected, calculate katipo-style cardnumber.
807 # otherwise, just use the max()
808 # purpose: generate checksum'd member numbers.
809 # We'll assume we just got the max value of digits 2-8 of member #'s
810 # from the database and our job is to increment that by one,
811 # determine the 1st and 9th digits and return the full string.
812 my $sth = $dbh->prepare(
813 "select max(substring(borrowers.cardnumber,2,7)) as new_num from borrowers"
816 my $data = $sth->fetchrow_hashref;
817 $cardnumber = $data->{new_num};
818 if ( !$cardnumber ) { # If DB has no values,
819 $cardnumber = 1000000; # start at 1000000
825 for ( my $i = 0 ; $i < 8 ; $i += 1 ) {
826 # read weightings, left to right, 1 char at a time
827 my $temp1 = $weightings[$i];
829 # sequence left to right, 1 char at a time
830 my $temp2 = substr( $cardnumber, $i, 1 );
832 # mult each char 1-7 by its corresponding weighting
833 $sum += $temp1 * $temp2;
836 my $rem = ( $sum % 11 );
837 $rem = 'X' if $rem == 10;
839 return "V$cardnumber$rem";
842 my $sth = $dbh->prepare(
843 'SELECT MAX( CAST( cardnumber AS SIGNED ) ) FROM borrowers WHERE cardnumber REGEXP "^-?[0-9]+$"'
846 my ($result) = $sth->fetchrow;
849 return $cardnumber; # just here as a fallback/reminder
852 =head2 GetPendingIssues
854 my $issues = &GetPendingIssues(@borrowernumber);
856 Looks up what the patron with the given borrowernumber has borrowed.
858 C<&GetPendingIssues> returns a
859 reference-to-array where each element is a reference-to-hash; the
860 keys are the fields from the C<issues>, C<biblio>, and C<items> tables.
861 The keys include C<biblioitems> fields except marc and marcxml.
865 sub GetPendingIssues {
866 my @borrowernumbers = @_;
868 unless (@borrowernumbers ) { # return a ref_to_array
869 return \@borrowernumbers; # to not cause surprise to caller
872 # Borrowers part of the query
874 for (my $i = 0; $i < @borrowernumbers; $i++) {
875 $bquery .= ' issues.borrowernumber = ?';
876 if ($i < $#borrowernumbers ) {
881 # must avoid biblioitems.* to prevent large marc and marcxml fields from killing performance
882 # FIXME: namespace collision: each table has "timestamp" fields. Which one is "timestamp" ?
883 # FIXME: circ/ciculation.pl tries to sort by timestamp!
884 # FIXME: namespace collision: other collisions possible.
885 # FIXME: most of this data isn't really being used by callers.
892 biblioitems.itemtype,
895 biblioitems.publicationyear,
896 biblioitems.publishercode,
897 biblioitems.volumedate,
898 biblioitems.volumedesc,
903 borrowers.cardnumber,
904 issues.timestamp AS timestamp,
905 issues.renewals AS renewals,
906 issues.borrowernumber AS borrowernumber,
907 items.renewals AS totalrenewals
909 LEFT JOIN items ON items.itemnumber = issues.itemnumber
910 LEFT JOIN biblio ON items.biblionumber = biblio.biblionumber
911 LEFT JOIN biblioitems ON items.biblioitemnumber = biblioitems.biblioitemnumber
912 LEFT JOIN borrowers ON issues.borrowernumber = borrowers.borrowernumber
915 ORDER BY issues.issuedate"
918 my $sth = C4::Context->dbh->prepare($query);
919 $sth->execute(@borrowernumbers);
920 my $data = $sth->fetchall_arrayref({});
921 my $today = dt_from_string;
923 if ($_->{issuedate}) {
924 $_->{issuedate} = dt_from_string($_->{issuedate}, 'sql');
926 $_->{date_due_sql} = $_->{date_due};
927 # FIXME no need to have this value
928 $_->{date_due} or next;
929 $_->{date_due_sql} = $_->{date_due};
930 # FIXME no need to have this value
931 $_->{date_due} = dt_from_string($_->{date_due}, 'sql');
932 if ( DateTime->compare($_->{date_due}, $today) == -1 ) {
941 $issues = &GetAllIssues($borrowernumber, $sortkey, $limit);
943 Looks up what the patron with the given borrowernumber has borrowed,
944 and sorts the results.
946 C<$sortkey> is the name of a field on which to sort the results. This
947 should be the name of a field in the C<issues>, C<biblio>,
948 C<biblioitems>, or C<items> table in the Koha database.
950 C<$limit> is the maximum number of results to return.
952 C<&GetAllIssues> an arrayref, C<$issues>, of hashrefs, the keys of which
953 are the fields from the C<issues>, C<biblio>, C<biblioitems>, and
954 C<items> tables of the Koha database.
960 my ( $borrowernumber, $order, $limit ) = @_;
962 return unless $borrowernumber;
963 $order = 'date_due desc' unless $order;
965 my $dbh = C4::Context->dbh;
967 'SELECT *, issues.timestamp as issuestimestamp, issues.renewals AS renewals,items.renewals AS totalrenewals,items.timestamp AS itemstimestamp
969 LEFT JOIN items on items.itemnumber=issues.itemnumber
970 LEFT JOIN biblio ON items.biblionumber=biblio.biblionumber
971 LEFT JOIN biblioitems ON items.biblioitemnumber=biblioitems.biblioitemnumber
972 WHERE borrowernumber=?
974 SELECT *, old_issues.timestamp as issuestimestamp, old_issues.renewals AS renewals,items.renewals AS totalrenewals,items.timestamp AS itemstimestamp
976 LEFT JOIN items on items.itemnumber=old_issues.itemnumber
977 LEFT JOIN biblio ON items.biblionumber=biblio.biblionumber
978 LEFT JOIN biblioitems ON items.biblioitemnumber=biblioitems.biblioitemnumber
979 WHERE borrowernumber=? AND old_issues.itemnumber IS NOT NULL
982 $query .= " limit $limit";
985 my $sth = $dbh->prepare($query);
986 $sth->execute( $borrowernumber, $borrowernumber );
987 return $sth->fetchall_arrayref( {} );
991 =head2 GetMemberAccountRecords
993 ($total, $acctlines, $count) = &GetMemberAccountRecords($borrowernumber);
995 Looks up accounting data for the patron with the given borrowernumber.
997 C<&GetMemberAccountRecords> returns a three-element array. C<$acctlines> is a
998 reference-to-array, where each element is a reference-to-hash; the
999 keys are the fields of the C<accountlines> table in the Koha database.
1000 C<$count> is the number of elements in C<$acctlines>. C<$total> is the
1001 total amount outstanding for all of the account lines.
1005 sub GetMemberAccountRecords {
1006 my ($borrowernumber) = @_;
1007 my $dbh = C4::Context->dbh;
1013 WHERE borrowernumber=?);
1014 $strsth.=" ORDER BY accountlines_id desc";
1015 my $sth= $dbh->prepare( $strsth );
1016 $sth->execute( $borrowernumber );
1019 while ( my $data = $sth->fetchrow_hashref ) {
1020 if ( $data->{itemnumber} ) {
1021 my $biblio = GetBiblioFromItemNumber( $data->{itemnumber} );
1022 $data->{biblionumber} = $biblio->{biblionumber};
1023 $data->{title} = $biblio->{title};
1025 $acctlines[$numlines] = $data;
1027 $total += sprintf "%.0f", 1000*$data->{amountoutstanding}; # convert float to integer to avoid round-off errors
1030 return ( $total, \@acctlines,$numlines);
1033 =head2 GetMemberAccountBalance
1035 ($total_balance, $non_issue_balance, $other_charges) = &GetMemberAccountBalance($borrowernumber);
1037 Calculates amount immediately owing by the patron - non-issue charges.
1038 Based on GetMemberAccountRecords.
1039 Charges exempt from non-issue are:
1041 * Rent (rental) if RentalsInNoissuesCharge syspref is set to false
1042 * Manual invoices if ManInvInNoissuesCharge syspref is set to false
1046 sub GetMemberAccountBalance {
1047 my ($borrowernumber) = @_;
1049 my $ACCOUNT_TYPE_LENGTH = 5; # this is plain ridiculous...
1052 push @not_fines, 'Res' unless C4::Context->preference('HoldsInNoissuesCharge');
1053 push @not_fines, 'Rent' unless C4::Context->preference('RentalsInNoissuesCharge');
1054 unless ( C4::Context->preference('ManInvInNoissuesCharge') ) {
1055 my $dbh = C4::Context->dbh;
1056 my $man_inv_types = $dbh->selectcol_arrayref(qq{SELECT authorised_value FROM authorised_values WHERE category = 'MANUAL_INV'});
1057 push @not_fines, map substr($_, 0, $ACCOUNT_TYPE_LENGTH), @$man_inv_types;
1059 my %not_fine = map {$_ => 1} @not_fines;
1061 my ($total, $acctlines) = GetMemberAccountRecords($borrowernumber);
1062 my $other_charges = 0;
1063 foreach (@$acctlines) {
1064 $other_charges += $_->{amountoutstanding} if $not_fine{ substr($_->{accounttype}, 0, $ACCOUNT_TYPE_LENGTH) };
1067 return ( $total, $total - $other_charges, $other_charges);
1070 =head2 GetBorNotifyAcctRecord
1072 ($total, $acctlines, $count) = &GetBorNotifyAcctRecord($params,$notifyid);
1074 Looks up accounting data for the patron with the given borrowernumber per file number.
1076 C<&GetBorNotifyAcctRecord> returns a three-element array. C<$acctlines> is a
1077 reference-to-array, where each element is a reference-to-hash; the
1078 keys are the fields of the C<accountlines> table in the Koha database.
1079 C<$count> is the number of elements in C<$acctlines>. C<$total> is the
1080 total amount outstanding for all of the account lines.
1084 sub GetBorNotifyAcctRecord {
1085 my ( $borrowernumber, $notifyid ) = @_;
1086 my $dbh = C4::Context->dbh;
1089 my $sth = $dbh->prepare(
1092 WHERE borrowernumber=?
1094 AND amountoutstanding != '0'
1095 ORDER BY notify_id,accounttype
1098 $sth->execute( $borrowernumber, $notifyid );
1100 while ( my $data = $sth->fetchrow_hashref ) {
1101 if ( $data->{itemnumber} ) {
1102 my $biblio = GetBiblioFromItemNumber( $data->{itemnumber} );
1103 $data->{biblionumber} = $biblio->{biblionumber};
1104 $data->{title} = $biblio->{title};
1106 $acctlines[$numlines] = $data;
1108 $total += int(100 * $data->{'amountoutstanding'});
1111 return ( $total, \@acctlines, $numlines );
1114 =head2 checkuniquemember (OUEST-PROVENCE)
1116 ($result,$categorycode) = &checkuniquemember($collectivity,$surname,$firstname,$dateofbirth);
1118 Checks that a member exists or not in the database.
1120 C<&result> is nonzero (=exist) or 0 (=does not exist)
1121 C<&categorycode> is from categorycode table
1122 C<&collectivity> is 1 (= we add a collectivity) or 0 (= we add a physical member)
1123 C<&surname> is the surname
1124 C<&firstname> is the firstname (only if collectivity=0)
1125 C<&dateofbirth> is the date of birth in ISO format (only if collectivity=0)
1129 # FIXME: This function is not legitimate. Multiple patrons might have the same first/last name and birthdate.
1130 # This is especially true since first name is not even a required field.
1132 sub checkuniquemember {
1133 my ( $collectivity, $surname, $firstname, $dateofbirth ) = @_;
1134 my $dbh = C4::Context->dbh;
1135 my $request = ($collectivity) ?
1136 "SELECT borrowernumber,categorycode FROM borrowers WHERE surname=? " :
1138 "SELECT borrowernumber,categorycode FROM borrowers WHERE surname=? and firstname=? and dateofbirth=?" :
1139 "SELECT borrowernumber,categorycode FROM borrowers WHERE surname=? and firstname=?";
1140 my $sth = $dbh->prepare($request);
1141 if ($collectivity) {
1142 $sth->execute( uc($surname) );
1143 } elsif($dateofbirth){
1144 $sth->execute( uc($surname), ucfirst($firstname), $dateofbirth );
1146 $sth->execute( uc($surname), ucfirst($firstname));
1148 my @data = $sth->fetchrow;
1149 ( $data[0] ) and return $data[0], $data[1];
1153 sub checkcardnumber {
1154 my ( $cardnumber, $borrowernumber ) = @_;
1156 # If cardnumber is null, we assume they're allowed.
1157 return 0 unless defined $cardnumber;
1159 my $dbh = C4::Context->dbh;
1160 my $query = "SELECT * FROM borrowers WHERE cardnumber=?";
1161 $query .= " AND borrowernumber <> ?" if ($borrowernumber);
1162 my $sth = $dbh->prepare($query);
1165 ( $borrowernumber ? $borrowernumber : () )
1168 return 1 if $sth->fetchrow_hashref;
1170 my ( $min_length, $max_length ) = get_cardnumber_length();
1172 if length $cardnumber > $max_length
1173 or length $cardnumber < $min_length;
1178 =head2 get_cardnumber_length
1180 my ($min, $max) = C4::Members::get_cardnumber_length()
1182 Returns the minimum and maximum length for patron cardnumbers as
1183 determined by the CardnumberLength system preference, the
1184 BorrowerMandatoryField system preference, and the width of the
1189 sub get_cardnumber_length {
1190 my ( $min, $max ) = ( 0, 16 ); # borrowers.cardnumber is a nullable varchar(16)
1191 $min = 1 if C4::Context->preference('BorrowerMandatoryField') =~ /cardnumber/;
1192 if ( my $cardnumber_length = C4::Context->preference('CardnumberLength') ) {
1193 # Is integer and length match
1194 if ( $cardnumber_length =~ m|^\d+$| ) {
1195 $min = $max = $cardnumber_length
1196 if $cardnumber_length >= $min
1197 and $cardnumber_length <= $max;
1199 # Else assuming it is a range
1200 elsif ( $cardnumber_length =~ m|(\d*),(\d*)| ) {
1201 $min = $1 if $1 and $min < $1;
1202 $max = $2 if $2 and $max > $2;
1206 return ( $min, $max );
1209 =head2 GetFirstValidEmailAddress
1211 $email = GetFirstValidEmailAddress($borrowernumber);
1213 Return the first valid email address for a borrower, given the borrowernumber. For now, the order
1214 is defined as email, emailpro, B_email. Returns the empty string if the borrower has no email
1219 sub GetFirstValidEmailAddress {
1220 my $borrowernumber = shift;
1221 my $dbh = C4::Context->dbh;
1222 my $sth = $dbh->prepare( "SELECT email, emailpro, B_email FROM borrowers where borrowernumber = ? ");
1223 $sth->execute( $borrowernumber );
1224 my $data = $sth->fetchrow_hashref;
1226 if ($data->{'email'}) {
1227 return $data->{'email'};
1228 } elsif ($data->{'emailpro'}) {
1229 return $data->{'emailpro'};
1230 } elsif ($data->{'B_email'}) {
1231 return $data->{'B_email'};
1237 =head2 GetNoticeEmailAddress
1239 $email = GetNoticeEmailAddress($borrowernumber);
1241 Return the email address of borrower used for notices, given the borrowernumber.
1242 Returns the empty string if no email address.
1246 sub GetNoticeEmailAddress {
1247 my $borrowernumber = shift;
1249 my $which_address = C4::Context->preference("AutoEmailPrimaryAddress");
1250 # if syspref is set to 'first valid' (value == OFF), look up email address
1251 if ( $which_address eq 'OFF' ) {
1252 return GetFirstValidEmailAddress($borrowernumber);
1254 # specified email address field
1255 my $dbh = C4::Context->dbh;
1256 my $sth = $dbh->prepare( qq{
1257 SELECT $which_address AS primaryemail
1259 WHERE borrowernumber=?
1261 $sth->execute($borrowernumber);
1262 my $data = $sth->fetchrow_hashref;
1263 return $data->{'primaryemail'} || '';
1266 =head2 GetExpiryDate
1268 $expirydate = GetExpiryDate($categorycode, $dateenrolled);
1270 Calculate expiry date given a categorycode and starting date. Date argument must be in ISO format.
1271 Return date is also in ISO format.
1276 my ( $categorycode, $dateenrolled ) = @_;
1278 if ($categorycode) {
1279 my $dbh = C4::Context->dbh;
1280 my $sth = $dbh->prepare("SELECT enrolmentperiod,enrolmentperioddate FROM categories WHERE categorycode=?");
1281 $sth->execute($categorycode);
1282 $enrolments = $sth->fetchrow_hashref;
1284 # die "GetExpiryDate: for enrollmentperiod $enrolmentperiod (category '$categorycode') starting $dateenrolled.\n";
1285 my @date = split (/-/,$dateenrolled);
1286 if($enrolments->{enrolmentperiod}){
1287 return sprintf("%04d-%02d-%02d", Add_Delta_YM(@date,0,$enrolments->{enrolmentperiod}));
1289 return $enrolments->{enrolmentperioddate};
1293 =head2 GetUpcomingMembershipExpires
1295 my $expires = GetUpcomingMembershipExpires({
1296 branch => $branch, before => $before, after => $after,
1299 $branch is an optional branch code.
1300 $before/$after is an optional number of days before/after the date that
1301 is set by the preference MembershipExpiryDaysNotice.
1302 If the pref would be 14, before 2 and after 3, you will get all expires
1307 sub GetUpcomingMembershipExpires {
1308 my ( $params ) = @_;
1309 my $before = $params->{before} || 0;
1310 my $after = $params->{after} || 0;
1311 my $branch = $params->{branch};
1313 my $dbh = C4::Context->dbh;
1314 my $days = C4::Context->preference("MembershipExpiryDaysNotice") || 0;
1315 my $date1 = dt_from_string->add( days => $days - $before );
1316 my $date2 = dt_from_string->add( days => $days + $after );
1317 $date1= output_pref({ dt => $date1, dateformat => 'iso', dateonly => 1 });
1318 $date2= output_pref({ dt => $date2, dateformat => 'iso', dateonly => 1 });
1321 SELECT borrowers.*, categories.description,
1322 branches.branchname, branches.branchemail FROM borrowers
1323 LEFT JOIN branches USING (branchcode)
1324 LEFT JOIN categories USING (categorycode)
1327 $query.= 'WHERE branchcode=? AND dateexpiry BETWEEN ? AND ?';
1329 $query.= 'WHERE dateexpiry BETWEEN ? AND ?';
1332 my $sth = $dbh->prepare( $query );
1333 my @pars = $branch? ( $branch ): ();
1334 push @pars, $date1, $date2;
1335 $sth->execute( @pars );
1336 my $results = $sth->fetchall_arrayref( {} );
1340 =head2 GetborCatFromCatType
1342 ($codes_arrayref, $labels_hashref) = &GetborCatFromCatType();
1344 Looks up the different types of borrowers in the database. Returns two
1345 elements: a reference-to-array, which lists the borrower category
1346 codes, and a reference-to-hash, which maps the borrower category codes
1347 to category descriptions.
1352 sub GetborCatFromCatType {
1353 my ( $category_type, $action, $no_branch_limit ) = @_;
1355 my $branch_limit = $no_branch_limit
1357 : C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1359 # FIXME - This API seems both limited and dangerous.
1360 my $dbh = C4::Context->dbh;
1363 SELECT categories.categorycode, categories.description
1367 LEFT JOIN categories_branches ON categories.categorycode = categories_branches.categorycode
1370 $request .= " $action ";
1371 $request .= " AND (branchcode = ? OR branchcode IS NULL) GROUP BY description" if $branch_limit;
1373 $request .= " WHERE branchcode = ? OR branchcode IS NULL GROUP BY description" if $branch_limit;
1375 $request .= " ORDER BY categorycode";
1377 my $sth = $dbh->prepare($request);
1379 $action ? $category_type : (),
1380 $branch_limit ? $branch_limit : ()
1386 while ( my $data = $sth->fetchrow_hashref ) {
1387 push @codes, $data->{'categorycode'};
1388 $labels{ $data->{'categorycode'} } = $data->{'description'};
1391 return ( \@codes, \%labels );
1394 =head2 GetBorrowercategory
1396 $hashref = &GetBorrowercategory($categorycode);
1398 Given the borrower's category code, the function returns the corresponding
1399 data hashref for a comprehensive information display.
1403 sub GetBorrowercategory {
1405 my $dbh = C4::Context->dbh;
1409 "SELECT description,dateofbirthrequired,upperagelimit,category_type
1411 WHERE categorycode = ?"
1413 $sth->execute($catcode);
1415 $sth->fetchrow_hashref;
1419 } # sub getborrowercategory
1422 =head2 GetBorrowerCategorycode
1424 $categorycode = &GetBorrowerCategoryCode( $borrowernumber );
1426 Given the borrowernumber, the function returns the corresponding categorycode
1430 sub GetBorrowerCategorycode {
1431 my ( $borrowernumber ) = @_;
1432 my $dbh = C4::Context->dbh;
1433 my $sth = $dbh->prepare( qq{
1436 WHERE borrowernumber = ?
1438 $sth->execute( $borrowernumber );
1439 return $sth->fetchrow;
1442 =head2 GetBorrowercategoryList
1444 $arrayref_hashref = &GetBorrowercategoryList;
1445 If no category code provided, the function returns all the categories.
1449 sub GetBorrowercategoryList {
1450 my $no_branch_limit = @_ ? shift : 0;
1451 my $branch_limit = $no_branch_limit
1453 : C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1454 my $dbh = C4::Context->dbh;
1455 my $query = "SELECT categories.* FROM categories";
1457 LEFT JOIN categories_branches ON categories.categorycode = categories_branches.categorycode
1458 WHERE branchcode = ? OR branchcode IS NULL GROUP BY description
1460 $query .= " ORDER BY description";
1461 my $sth = $dbh->prepare( $query );
1462 $sth->execute( $branch_limit ? $branch_limit : () );
1463 my $data = $sth->fetchall_arrayref( {} );
1466 } # sub getborrowercategory
1470 $dateofbirth,$date = &GetAge($date);
1472 this function return the borrowers age with the value of dateofbirth
1478 my ( $date, $date_ref ) = @_;
1480 if ( not defined $date_ref ) {
1481 $date_ref = sprintf( '%04d-%02d-%02d', Today() );
1484 my ( $year1, $month1, $day1 ) = split /-/, $date;
1485 my ( $year2, $month2, $day2 ) = split /-/, $date_ref;
1487 my $age = $year2 - $year1;
1488 if ( $month1 . $day1 > $month2 . $day2 ) {
1497 $borrower = C4::Members::SetAge($borrower, $datetimeduration);
1498 $borrower = C4::Members::SetAge($borrower, '0015-12-10');
1499 $borrower = C4::Members::SetAge($borrower, $datetimeduration, $datetime_reference);
1501 eval { $borrower = C4::Members::SetAge($borrower, '015-1-10'); };
1502 if ($@) {print $@;} #Catch a bad ISO Date or kill your script!
1504 This function sets the borrower's dateofbirth to match the given age.
1505 Optionally relative to the given $datetime_reference.
1507 @PARAM1 koha.borrowers-object
1508 @PARAM2 DateTime::Duration-object as the desired age
1509 OR a ISO 8601 Date. (To make the API more pleasant)
1510 @PARAM3 DateTime-object as the relative date, defaults to now().
1511 RETURNS The given borrower reference @PARAM1.
1512 DIES If there was an error with the ISO Date handling.
1518 my ( $borrower, $datetimeduration, $datetime_ref ) = @_;
1519 $datetime_ref = DateTime->now() unless $datetime_ref;
1521 if ($datetimeduration && ref $datetimeduration ne 'DateTime::Duration') {
1522 if ($datetimeduration =~ /^(\d{4})-(\d{2})-(\d{2})/) {
1523 $datetimeduration = DateTime::Duration->new(years => $1, months => $2, days => $3);
1526 die "C4::Members::SetAge($borrower, $datetimeduration), datetimeduration not a valid ISO 8601 Date!\n";
1530 my $new_datetime_ref = $datetime_ref->clone();
1531 $new_datetime_ref->subtract_duration( $datetimeduration );
1533 $borrower->{dateofbirth} = $new_datetime_ref->ymd();
1538 =head2 GetSortDetails (OUEST-PROVENCE)
1540 ($lib) = &GetSortDetails($category,$sortvalue);
1542 Returns the authorized value details
1543 C<&$lib>return value of authorized value details
1544 C<&$sortvalue>this is the value of authorized value
1545 C<&$category>this is the value of authorized value category
1549 sub GetSortDetails {
1550 my ( $category, $sortvalue ) = @_;
1551 my $dbh = C4::Context->dbh;
1552 my $query = qq|SELECT lib
1553 FROM authorised_values
1555 AND authorised_value=? |;
1556 my $sth = $dbh->prepare($query);
1557 $sth->execute( $category, $sortvalue );
1558 my $lib = $sth->fetchrow;
1559 return ($lib) if ($lib);
1560 return ($sortvalue) unless ($lib);
1563 =head2 MoveMemberToDeleted
1565 $result = &MoveMemberToDeleted($borrowernumber);
1567 Copy the record from borrowers to deletedborrowers table.
1568 The routine returns 1 for success, undef for failure.
1572 sub MoveMemberToDeleted {
1573 my ($member) = shift or return;
1575 my $schema = Koha::Database->new()->schema();
1576 my $borrowers_rs = $schema->resultset('Borrower');
1577 $borrowers_rs->result_class('DBIx::Class::ResultClass::HashRefInflator');
1578 my $borrower = $borrowers_rs->find($member);
1579 return unless $borrower;
1581 my $deleted = $schema->resultset('Deletedborrower')->create($borrower);
1583 return $deleted ? 1 : undef;
1588 DelMember($borrowernumber);
1590 This function remove directly a borrower whitout writing it on deleteborrower.
1591 + Deletes reserves for the borrower
1596 my $dbh = C4::Context->dbh;
1597 my $borrowernumber = shift;
1598 #warn "in delmember with $borrowernumber";
1599 return unless $borrowernumber; # borrowernumber is mandatory.
1600 # Delete Patron's holds
1601 my @holds = Koha::Holds->search({ borrowernumber => $borrowernumber });
1602 $_->delete for @holds;
1607 WHERE borrowernumber = ?
1609 my $sth = $dbh->prepare($query);
1610 $sth->execute($borrowernumber);
1611 logaction("MEMBERS", "DELETE", $borrowernumber, "") if C4::Context->preference("BorrowersLog");
1615 =head2 HandleDelBorrower
1617 HandleDelBorrower($borrower);
1619 When a member is deleted (DelMember in Members.pm), you should call me first.
1620 This routine deletes/moves lists and entries for the deleted member/borrower.
1621 Lists owned by the borrower are deleted, but entries from the borrower to
1622 other lists are kept.
1626 sub HandleDelBorrower {
1629 my $dbh = C4::Context->dbh;
1631 #Delete all lists and all shares of this borrower
1632 #Consistent with the approach Koha uses on deleting individual lists
1633 #Note that entries in virtualshelfcontents added by this borrower to
1634 #lists of others will be handled by a table constraint: the borrower
1635 #is set to NULL in those entries.
1636 $query="DELETE FROM virtualshelves WHERE owner=?";
1637 $dbh->do($query,undef,($borrower));
1640 #We could handle the above deletes via a constraint too.
1641 #But a new BZ report 11889 has been opened to discuss another approach.
1642 #Instead of deleting we could also disown lists (based on a pref).
1643 #In that way we could save shared and public lists.
1644 #The current table constraints support that idea now.
1645 #This pref should then govern the results of other routines/methods such as
1646 #Koha::Virtualshelf->new->delete too.
1649 =head2 ExtendMemberSubscriptionTo (OUEST-PROVENCE)
1651 $date = ExtendMemberSubscriptionTo($borrowerid, $date);
1653 Extending the subscription to a given date or to the expiry date calculated on ISO date.
1658 sub ExtendMemberSubscriptionTo {
1659 my ( $borrowerid,$date) = @_;
1660 my $dbh = C4::Context->dbh;
1661 my $borrower = GetMember('borrowernumber'=>$borrowerid);
1663 $date = (C4::Context->preference('BorrowerRenewalPeriodBase') eq 'dateexpiry') ?
1664 eval { output_pref( { dt => dt_from_string( $borrower->{'dateexpiry'} ), dateonly => 1, dateformat => 'iso' } ); }
1666 output_pref( { dt => dt_from_string, dateonly => 1, dateformat => 'iso' } );
1667 $date = GetExpiryDate( $borrower->{'categorycode'}, $date );
1669 my $sth = $dbh->do(<<EOF);
1671 SET dateexpiry='$date'
1672 WHERE borrowernumber='$borrowerid'
1675 AddEnrolmentFeeIfNeeded( $borrower->{categorycode}, $borrower->{borrowernumber} );
1677 logaction("MEMBERS", "RENEW", $borrower->{'borrowernumber'}, "Membership renewed")if C4::Context->preference("BorrowersLog");
1678 return $date if ($sth);
1682 =head2 GetTitles (OUEST-PROVENCE)
1684 ($borrowertitle)= &GetTitles();
1686 Looks up the different title . Returns array with all borrowers title
1691 my @borrowerTitle = split (/,|\|/,C4::Context->preference('BorrowersTitles'));
1692 unshift( @borrowerTitle, "" );
1693 my $count=@borrowerTitle;
1698 return ( \@borrowerTitle);
1702 =head2 GetHideLostItemsPreference
1704 $hidelostitemspref = &GetHideLostItemsPreference($borrowernumber);
1706 Returns the HideLostItems preference for the patron category of the supplied borrowernumber
1707 C<&$hidelostitemspref>return value of function, 0 or 1
1711 sub GetHideLostItemsPreference {
1712 my ($borrowernumber) = @_;
1713 my $dbh = C4::Context->dbh;
1714 my $query = "SELECT hidelostitems FROM borrowers,categories WHERE borrowers.categorycode = categories.categorycode AND borrowernumber = ?";
1715 my $sth = $dbh->prepare($query);
1716 $sth->execute($borrowernumber);
1717 my $hidelostitems = $sth->fetchrow;
1718 return $hidelostitems;
1721 =head2 GetBorrowersToExpunge
1723 $borrowers = &GetBorrowersToExpunge(
1724 not_borrowed_since => $not_borrowed_since,
1725 expired_before => $expired_before,
1726 category_code => $category_code,
1727 patron_list_id => $patron_list_id,
1728 branchcode => $branchcode
1731 This function get all borrowers based on the given criteria.
1735 sub GetBorrowersToExpunge {
1738 my $filterdate = $params->{'not_borrowed_since'};
1739 my $filterexpiry = $params->{'expired_before'};
1740 my $filtercategory = $params->{'category_code'};
1741 my $filterbranch = $params->{'branchcode'} ||
1742 ((C4::Context->preference('IndependentBranches')
1743 && C4::Context->userenv
1744 && !C4::Context->IsSuperLibrarian()
1745 && C4::Context->userenv->{branch})
1746 ? C4::Context->userenv->{branch}
1748 my $filterpatronlist = $params->{'patron_list_id'};
1750 my $dbh = C4::Context->dbh;
1752 SELECT borrowers.borrowernumber,
1753 MAX(old_issues.timestamp) AS latestissue,
1754 MAX(issues.timestamp) AS currentissue
1756 JOIN categories USING (categorycode)
1760 WHERE guarantorid IS NOT NULL
1761 AND guarantorid <> 0
1762 ) as tmp ON borrowers.borrowernumber=tmp.guarantorid
1763 LEFT JOIN old_issues USING (borrowernumber)
1764 LEFT JOIN issues USING (borrowernumber)|;
1765 if ( $filterpatronlist ){
1766 $query .= q| LEFT JOIN patron_list_patrons USING (borrowernumber)|;
1768 $query .= q| WHERE category_type <> 'S'
1769 AND tmp.guarantorid IS NULL
1772 if ( $filterbranch && $filterbranch ne "" ) {
1773 $query.= " AND borrowers.branchcode = ? ";
1774 push( @query_params, $filterbranch );
1776 if ( $filterexpiry ) {
1777 $query .= " AND dateexpiry < ? ";
1778 push( @query_params, $filterexpiry );
1780 if ( $filtercategory ) {
1781 $query .= " AND categorycode = ? ";
1782 push( @query_params, $filtercategory );
1784 if ( $filterpatronlist ){
1785 $query.=" AND patron_list_id = ? ";
1786 push( @query_params, $filterpatronlist );
1788 $query.=" GROUP BY borrowers.borrowernumber HAVING currentissue IS NULL ";
1789 if ( $filterdate ) {
1790 $query.=" AND ( latestissue < ? OR latestissue IS NULL ) ";
1791 push @query_params,$filterdate;
1793 warn $query if $debug;
1795 my $sth = $dbh->prepare($query);
1796 if (scalar(@query_params)>0){
1797 $sth->execute(@query_params);
1804 while ( my $data = $sth->fetchrow_hashref ) {
1805 push @results, $data;
1810 =head2 GetBorrowersWhoHaveNeverBorrowed
1812 $results = &GetBorrowersWhoHaveNeverBorrowed
1814 This function get all borrowers who have never borrowed.
1816 I<$result> is a ref to an array which all elements are a hasref.
1820 sub GetBorrowersWhoHaveNeverBorrowed {
1821 my $filterbranch = shift ||
1822 ((C4::Context->preference('IndependentBranches')
1823 && C4::Context->userenv
1824 && !C4::Context->IsSuperLibrarian()
1825 && C4::Context->userenv->{branch})
1826 ? C4::Context->userenv->{branch}
1828 my $dbh = C4::Context->dbh;
1830 SELECT borrowers.borrowernumber,max(timestamp) as latestissue
1832 LEFT JOIN issues ON borrowers.borrowernumber = issues.borrowernumber
1833 WHERE issues.borrowernumber IS NULL
1836 if ($filterbranch && $filterbranch ne ""){
1837 $query.=" AND borrowers.branchcode= ?";
1838 push @query_params,$filterbranch;
1840 warn $query if $debug;
1842 my $sth = $dbh->prepare($query);
1843 if (scalar(@query_params)>0){
1844 $sth->execute(@query_params);
1851 while ( my $data = $sth->fetchrow_hashref ) {
1852 push @results, $data;
1857 =head2 GetBorrowersWithIssuesHistoryOlderThan
1859 $results = &GetBorrowersWithIssuesHistoryOlderThan($date)
1861 this function get all borrowers who has an issue history older than I<$date> given on input arg.
1863 I<$result> is a ref to an array which all elements are a hashref.
1864 This hashref is containt the number of time this borrowers has borrowed before I<$date> and the borrowernumber.
1868 sub GetBorrowersWithIssuesHistoryOlderThan {
1869 my $dbh = C4::Context->dbh;
1870 my $date = shift ||POSIX::strftime("%Y-%m-%d",localtime());
1871 my $filterbranch = shift ||
1872 ((C4::Context->preference('IndependentBranches')
1873 && C4::Context->userenv
1874 && !C4::Context->IsSuperLibrarian()
1875 && C4::Context->userenv->{branch})
1876 ? C4::Context->userenv->{branch}
1879 SELECT count(borrowernumber) as n,borrowernumber
1881 WHERE returndate < ?
1882 AND borrowernumber IS NOT NULL
1885 push @query_params, $date;
1887 $query.=" AND branchcode = ?";
1888 push @query_params, $filterbranch;
1890 $query.=" GROUP BY borrowernumber ";
1891 warn $query if $debug;
1892 my $sth = $dbh->prepare($query);
1893 $sth->execute(@query_params);
1896 while ( my $data = $sth->fetchrow_hashref ) {
1897 push @results, $data;
1902 =head2 GetBorrowersNamesAndLatestIssue
1904 $results = &GetBorrowersNamesAndLatestIssueList(@borrowernumbers)
1906 this function get borrowers Names and surnames and Issue information.
1908 I<@borrowernumbers> is an array which all elements are borrowernumbers.
1909 This hashref is containt the number of time this borrowers has borrowed before I<$date> and the borrowernumber.
1913 sub GetBorrowersNamesAndLatestIssue {
1914 my $dbh = C4::Context->dbh;
1915 my @borrowernumbers=@_;
1917 SELECT surname,lastname, phone, email,max(timestamp)
1919 LEFT JOIN issues ON borrowers.borrowernumber=issues.borrowernumber
1920 GROUP BY borrowernumber
1922 my $sth = $dbh->prepare($query);
1924 my $results = $sth->fetchall_arrayref({});
1930 IssueSlip($branchcode, $borrowernumber, $quickslip)
1932 Returns letter hash ( see C4::Letters::GetPreparedLetter )
1934 $quickslip is boolean, to indicate whether we want a quick slip
1936 IssueSlip populates ISSUESLIP and ISSUEQSLIP, and will make the following expansions:
1972 NOTE: Not all table fields are available, pleasee see GetPendingIssues for a list of available fields.
1977 my ($branch, $borrowernumber, $quickslip) = @_;
1979 # FIXME Check callers before removing this statement
1980 #return unless $borrowernumber;
1982 my @issues = @{ GetPendingIssues($borrowernumber) };
1984 for my $issue (@issues) {
1985 $issue->{date_due} = $issue->{date_due_sql};
1987 my $today = output_pref({ dt => dt_from_string, dateformat => 'iso', dateonly => 1 });
1988 if ( substr( $issue->{issuedate}, 0, 10 ) eq $today
1989 or substr( $issue->{lastreneweddate}, 0, 10 ) eq $today ) {
1995 # Sort on timestamp then on issuedate (useful for tests and could be if modified in a batch
1997 my $s = $b->{timestamp} <=> $a->{timestamp};
1999 $b->{issuedate} <=> $a->{issuedate} : $s;
2002 my ($letter_code, %repeat);
2004 $letter_code = 'ISSUEQSLIP';
2006 'checkedout' => [ map {
2009 'biblioitems' => $_,
2011 }, grep { $_->{'now'} } @issues ],
2015 $letter_code = 'ISSUESLIP';
2017 'checkedout' => [ map {
2020 'biblioitems' => $_,
2022 }, grep { !$_->{'overdue'} } @issues ],
2024 'overdue' => [ map {
2027 'biblioitems' => $_,
2029 }, grep { $_->{'overdue'} } @issues ],
2032 $_->{'timestamp'} = $_->{'newdate'};
2034 } @{ GetNewsToDisplay("slip",$branch) } ],
2038 return C4::Letters::GetPreparedLetter (
2039 module => 'circulation',
2040 letter_code => $letter_code,
2041 branchcode => $branch,
2043 'branches' => $branch,
2044 'borrowers' => $borrowernumber,
2050 =head2 GetBorrowersWithEmail
2052 ([$borrnum,$userid], ...) = GetBorrowersWithEmail('me@example.com');
2054 This gets a list of users and their basic details from their email address.
2055 As it's possible for multiple user to have the same email address, it provides
2056 you with all of them. If there is no userid for the user, there will be an
2057 C<undef> there. An empty list will be returned if there are no matches.
2061 sub GetBorrowersWithEmail {
2064 my $dbh = C4::Context->dbh;
2066 my $query = "SELECT borrowernumber, userid FROM borrowers WHERE email=?";
2067 my $sth=$dbh->prepare($query);
2068 $sth->execute($email);
2070 while (my $ref = $sth->fetch) {
2073 die "Failure searching for borrowers by email address: $sth->errstr" if $sth->err;
2077 =head2 AddMember_Opac
2081 sub AddMember_Opac {
2082 my ( %borrower ) = @_;
2084 $borrower{'categorycode'} //= C4::Context->preference('PatronSelfRegistrationDefaultCategory');
2085 if (not defined $borrower{'password'}){
2086 my $sr = new String::Random;
2087 $sr->{'A'} = [ 'A'..'Z', 'a'..'z' ];
2088 my $password = $sr->randpattern("AAAAAAAAAA");
2089 $borrower{'password'} = $password;
2092 $borrower{'cardnumber'} = fixup_cardnumber( $borrower{'cardnumber'} );
2094 my $borrowernumber = AddMember(%borrower);
2096 return ( $borrowernumber, $borrower{'password'} );
2099 =head2 AddEnrolmentFeeIfNeeded
2101 AddEnrolmentFeeIfNeeded( $borrower->{categorycode}, $borrower->{borrowernumber} );
2103 Add enrolment fee for a patron if needed.
2107 sub AddEnrolmentFeeIfNeeded {
2108 my ( $categorycode, $borrowernumber ) = @_;
2109 # check for enrollment fee & add it if needed
2110 my $dbh = C4::Context->dbh;
2111 my $sth = $dbh->prepare(q{
2114 WHERE categorycode=?
2116 $sth->execute( $categorycode );
2118 warn sprintf('Database returned the following error: %s', $sth->errstr);
2121 my ($enrolmentfee) = $sth->fetchrow;
2122 if ($enrolmentfee && $enrolmentfee > 0) {
2123 # insert fee in patron debts
2124 C4::Accounts::manualinvoice( $borrowernumber, '', '', 'A', $enrolmentfee );
2133 my ( $borrowernumber ) = @_;
2135 my $sql = "SELECT COUNT(*) FROM issues WHERE date_due < NOW() AND borrowernumber = ?";
2136 my $sth = C4::Context->dbh->prepare( $sql );
2137 $sth->execute( $borrowernumber );
2138 my ( $count ) = $sth->fetchrow_array();
2143 =head2 DeleteExpiredOpacRegistrations
2145 Delete accounts that haven't been upgraded from the 'temporary' category
2146 Returns the number of removed patrons
2150 sub DeleteExpiredOpacRegistrations {
2152 my $delay = C4::Context->preference('PatronSelfRegistrationExpireTemporaryAccountsDelay');
2153 my $category_code = C4::Context->preference('PatronSelfRegistrationDefaultCategory');
2155 return 0 if not $category_code or not defined $delay or $delay eq q||;
2158 SELECT borrowernumber
2160 WHERE categorycode = ? AND DATEDIFF( NOW(), dateenrolled ) > ? |;
2162 my $dbh = C4::Context->dbh;
2163 my $sth = $dbh->prepare($query);
2164 $sth->execute( $category_code, $delay );
2166 while ( my ($borrowernumber) = $sth->fetchrow_array() ) {
2167 DelMember($borrowernumber);
2173 =head2 DeleteUnverifiedOpacRegistrations
2175 Delete all unverified self registrations in borrower_modifications,
2176 older than the specified number of days.
2180 sub DeleteUnverifiedOpacRegistrations {
2182 my $dbh = C4::Context->dbh;
2184 DELETE FROM borrower_modifications
2185 WHERE borrowernumber = 0 AND DATEDIFF( NOW(), timestamp ) > ?|;
2186 my $cnt=$dbh->do($sql, undef, ($days) );
2187 return $cnt eq '0E0'? 0: $cnt;
2190 sub GetOverduesForPatron {
2191 my ( $borrowernumber ) = @_;
2195 FROM issues, items, biblio, biblioitems
2196 WHERE items.itemnumber=issues.itemnumber
2197 AND biblio.biblionumber = items.biblionumber
2198 AND biblio.biblionumber = biblioitems.biblionumber
2199 AND issues.borrowernumber = ?
2200 AND date_due < NOW()
2203 my $sth = C4::Context->dbh->prepare( $sql );
2204 $sth->execute( $borrowernumber );
2206 return $sth->fetchall_arrayref({});
2209 END { } # module clean-up code here (global destructor)