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
83 GetBorrowerCategorycode
84 &GetBorrowercategoryList
86 &GetBorrowersToExpunge
87 &GetBorrowersWhoHaveNeverBorrowed
88 &GetBorrowersWithIssuesHistoryOlderThan
91 &GetUpcomingMembershipExpires
116 &ExtendMemberSubscriptionTo
132 C4::Members - Perl Module containing convenience functions for member handling
140 This module contains routines for adding, modifying and deleting members/patrons/borrowers
144 =head2 GetMemberDetails
146 ($borrower) = &GetMemberDetails($borrowernumber, $cardnumber);
148 Looks up a patron and returns information about him or her. If
149 C<$borrowernumber> is true (nonzero), C<&GetMemberDetails> looks
150 up the borrower by number; otherwise, it looks up the borrower by card
153 C<$borrower> is a reference-to-hash whose keys are the fields of the
154 borrowers table in the Koha database. In addition,
155 C<$borrower-E<gt>{flags}> is a hash giving more detailed information
156 about the patron. Its keys act as flags :
158 if $borrower->{flags}->{LOST} {
159 # Patron's card was reported lost
162 If the state of a flag means that the patron should not be
163 allowed to borrow any more books, then it will have a C<noissues> key
166 See patronflags for more details.
168 C<$borrower-E<gt>{authflags}> is a hash giving more detailed information
169 about the top-level permissions flags set for the borrower. For example,
170 if a user has the "editcatalogue" permission,
171 C<$borrower-E<gt>{authflags}-E<gt>{editcatalogue}> will exist and have
176 sub GetMemberDetails {
177 my ( $borrowernumber, $cardnumber ) = @_;
178 my $dbh = C4::Context->dbh;
181 if ($borrowernumber) {
182 $sth = $dbh->prepare("
185 categories.description,
186 categories.BlockExpiredPatronOpacActions,
190 LEFT JOIN categories ON borrowers.categorycode=categories.categorycode
191 WHERE borrowernumber = ?
193 $sth->execute($borrowernumber);
195 elsif ($cardnumber) {
196 $sth = $dbh->prepare("
199 categories.description,
200 categories.BlockExpiredPatronOpacActions,
204 LEFT JOIN categories ON borrowers.categorycode = categories.categorycode
207 $sth->execute($cardnumber);
212 my $borrower = $sth->fetchrow_hashref;
213 return unless $borrower;
214 my ($amount) = GetMemberAccountRecords($borrower->{borrowernumber});
215 $borrower->{'amountoutstanding'} = $amount;
216 # FIXME - patronflags calls GetMemberAccountRecords... just have patronflags return $amount
217 my $flags = patronflags( $borrower);
220 $sth = $dbh->prepare("select bit,flag from userflags");
222 while ( my ( $bit, $flag ) = $sth->fetchrow ) {
223 if ( $borrower->{'flags'} && $borrower->{'flags'} & 2**$bit ) {
224 $accessflagshash->{$flag} = 1;
227 $borrower->{'flags'} = $flags;
228 $borrower->{'authflags'} = $accessflagshash;
230 # Handle setting the true behavior for BlockExpiredPatronOpacActions
231 $borrower->{'BlockExpiredPatronOpacActions'} =
232 C4::Context->preference('BlockExpiredPatronOpacActions')
233 if ( $borrower->{'BlockExpiredPatronOpacActions'} == -1 );
235 $borrower->{'is_expired'} = 0;
236 $borrower->{'is_expired'} = 1 if
237 defined($borrower->{dateexpiry}) &&
238 $borrower->{'dateexpiry'} ne '0000-00-00' &&
239 Date_to_Days( Today() ) >
240 Date_to_Days( split /-/, $borrower->{'dateexpiry'} );
242 return ($borrower); #, $flags, $accessflagshash);
247 $flags = &patronflags($patron);
249 This function is not exported.
251 The following will be set where applicable:
252 $flags->{CHARGES}->{amount} Amount of debt
253 $flags->{CHARGES}->{noissues} Set if debt amount >$5.00 (or syspref noissuescharge)
254 $flags->{CHARGES}->{message} Message -- deprecated
256 $flags->{CREDITS}->{amount} Amount of credit
257 $flags->{CREDITS}->{message} Message -- deprecated
259 $flags->{ GNA } Patron has no valid address
260 $flags->{ GNA }->{noissues} Set for each GNA
261 $flags->{ GNA }->{message} "Borrower has no valid address" -- deprecated
263 $flags->{ LOST } Patron's card reported lost
264 $flags->{ LOST }->{noissues} Set for each LOST
265 $flags->{ LOST }->{message} Message -- deprecated
267 $flags->{DBARRED} Set if patron debarred, no access
268 $flags->{DBARRED}->{noissues} Set for each DBARRED
269 $flags->{DBARRED}->{message} Message -- deprecated
272 $flags->{ NOTES }->{message} The note itself. NOT deprecated
274 $flags->{ ODUES } Set if patron has overdue books.
275 $flags->{ ODUES }->{message} "Yes" -- deprecated
276 $flags->{ ODUES }->{itemlist} ref-to-array: list of overdue books
277 $flags->{ ODUES }->{itemlisttext} Text list of overdue items -- deprecated
279 $flags->{WAITING} Set if any of patron's reserves are available
280 $flags->{WAITING}->{message} Message -- deprecated
281 $flags->{WAITING}->{itemlist} ref-to-array: list of available items
285 =item C<$flags-E<gt>{ODUES}-E<gt>{itemlist}> is a reference-to-array listing the
286 overdue items. Its elements are references-to-hash, each describing an
287 overdue item. The keys are selected fields from the issues, biblio,
288 biblioitems, and items tables of the Koha database.
290 =item C<$flags-E<gt>{ODUES}-E<gt>{itemlisttext}> is a string giving a text listing of
291 the overdue items, one per line. Deprecated.
293 =item C<$flags-E<gt>{WAITING}-E<gt>{itemlist}> is a reference-to-array listing the
294 available items. Each element is a reference-to-hash whose keys are
295 fields from the reserves table of the Koha database.
299 All the "message" fields that include language generated in this function are deprecated,
300 because such strings belong properly in the display layer.
302 The "message" field that comes from the DB is OK.
306 # TODO: use {anonymous => hashes} instead of a dozen %flaginfo
307 # FIXME rename this function.
310 my ( $patroninformation) = @_;
311 my $dbh=C4::Context->dbh;
312 my ($balance, $owing) = GetMemberAccountBalance( $patroninformation->{'borrowernumber'});
315 my $noissuescharge = C4::Context->preference("noissuescharge") || 5;
316 $flaginfo{'message'} = sprintf 'Patron owes %.02f', $owing;
317 $flaginfo{'amount'} = sprintf "%.02f", $owing;
318 if ( $owing > $noissuescharge && !C4::Context->preference("AllowFineOverride") ) {
319 $flaginfo{'noissues'} = 1;
321 $flags{'CHARGES'} = \%flaginfo;
323 elsif ( $balance < 0 ) {
325 $flaginfo{'message'} = sprintf 'Patron has credit of %.02f', -$balance;
326 $flaginfo{'amount'} = sprintf "%.02f", $balance;
327 $flags{'CREDITS'} = \%flaginfo;
330 # Check the debt of the guarntees of this patron
331 my $no_issues_charge_guarantees = C4::Context->preference("NoIssuesChargeGuarantees");
332 $no_issues_charge_guarantees = undef unless looks_like_number( $no_issues_charge_guarantees );
333 if ( defined $no_issues_charge_guarantees ) {
334 my $p = Koha::Patrons->find( $patroninformation->{borrowernumber} );
335 my @guarantees = $p->guarantees();
336 my $guarantees_non_issues_charges;
337 foreach my $g ( @guarantees ) {
338 my ( $b, $n, $o ) = C4::Members::GetMemberAccountBalance( $g->id );
339 $guarantees_non_issues_charges += $n;
342 if ( $guarantees_non_issues_charges > $no_issues_charge_guarantees ) {
344 $flaginfo{'message'} = sprintf 'patron guarantees owe %.02f', $guarantees_non_issues_charges;
345 $flaginfo{'amount'} = $guarantees_non_issues_charges;
346 $flaginfo{'noissues'} = 1 unless C4::Context->preference("allowfineoverride");
347 $flags{'CHARGES_GUARANTEES'} = \%flaginfo;
351 if ( $patroninformation->{'gonenoaddress'}
352 && $patroninformation->{'gonenoaddress'} == 1 )
355 $flaginfo{'message'} = 'Borrower has no valid address.';
356 $flaginfo{'noissues'} = 1;
357 $flags{'GNA'} = \%flaginfo;
359 if ( $patroninformation->{'lost'} && $patroninformation->{'lost'} == 1 ) {
361 $flaginfo{'message'} = 'Borrower\'s card reported lost.';
362 $flaginfo{'noissues'} = 1;
363 $flags{'LOST'} = \%flaginfo;
365 if ( $patroninformation->{'debarred'} && check_date( split( /-/, $patroninformation->{'debarred'} ) ) ) {
366 if ( Date_to_Days(Date::Calc::Today) < Date_to_Days( split( /-/, $patroninformation->{'debarred'} ) ) ) {
368 $flaginfo{'debarredcomment'} = $patroninformation->{'debarredcomment'};
369 $flaginfo{'message'} = $patroninformation->{'debarredcomment'};
370 $flaginfo{'noissues'} = 1;
371 $flaginfo{'dateend'} = $patroninformation->{'debarred'};
372 $flags{'DBARRED'} = \%flaginfo;
375 if ( $patroninformation->{'borrowernotes'}
376 && $patroninformation->{'borrowernotes'} )
379 $flaginfo{'message'} = $patroninformation->{'borrowernotes'};
380 $flags{'NOTES'} = \%flaginfo;
382 my ( $odues, $itemsoverdue ) = C4::Overdues::checkoverdues($patroninformation->{'borrowernumber'});
383 if ( $odues && $odues > 0 ) {
385 $flaginfo{'message'} = "Yes";
386 $flaginfo{'itemlist'} = $itemsoverdue;
387 foreach ( sort { $a->{'date_due'} cmp $b->{'date_due'} }
390 $flaginfo{'itemlisttext'} .=
391 "$_->{'date_due'} $_->{'barcode'} $_->{'title'} \n"; # newline is display layer
393 $flags{'ODUES'} = \%flaginfo;
395 my @itemswaiting = C4::Reserves::GetReservesFromBorrowernumber( $patroninformation->{'borrowernumber'},'W' );
396 my $nowaiting = scalar @itemswaiting;
397 if ( $nowaiting > 0 ) {
399 $flaginfo{'message'} = "Reserved items available";
400 $flaginfo{'itemlist'} = \@itemswaiting;
401 $flags{'WAITING'} = \%flaginfo;
409 $borrower = &GetMember(%information);
411 Retrieve the first patron record meeting on criteria listed in the
412 C<%information> hash, which should contain one or more
413 pairs of borrowers column names and values, e.g.,
415 $borrower = GetMember(borrowernumber => id);
417 C<&GetBorrower> returns a reference-to-hash whose keys are the fields of
418 the C<borrowers> table in the Koha database.
420 FIXME: GetMember() is used throughout the code as a lookup
421 on a unique key such as the borrowernumber, but this meaning is not
422 enforced in the routine itself.
428 my ( %information ) = @_;
429 if (exists $information{borrowernumber} && !defined $information{borrowernumber}) {
430 #passing mysql's kohaadmin?? Makes no sense as a query
433 my $dbh = C4::Context->dbh;
435 q{SELECT borrowers.*, categories.category_type, categories.description
437 LEFT JOIN categories on borrowers.categorycode=categories.categorycode WHERE };
440 for (keys %information ) {
448 if (defined $information{$_}) {
450 push @values, $information{$_};
453 $select .= "$_ IS NULL";
456 $debug && warn $select, " ",values %information;
457 my $sth = $dbh->prepare("$select");
458 $sth->execute(@values);
459 my $data = $sth->fetchall_arrayref({});
460 #FIXME interface to this routine now allows generation of a result set
461 #so whole array should be returned but bowhere in the current code expects this
469 =head2 IsMemberBlocked
471 my ($block_status, $count) = IsMemberBlocked( $borrowernumber );
473 Returns whether a patron is restricted or has overdue items that may result
474 in a block of circulation privileges.
476 C<$block_status> can have the following values:
478 1 if the patron is currently restricted, in which case
479 C<$count> is the expiration date (9999-12-31 for indefinite)
481 -1 if the patron has overdue items, in which case C<$count> is the number of them
483 0 if the patron has no overdue items or outstanding fine days, in which case C<$count> is 0
485 Existing active restrictions are checked before current overdue items.
489 sub IsMemberBlocked {
490 my $borrowernumber = shift;
491 my $dbh = C4::Context->dbh;
493 my $blockeddate = Koha::Patrons->find( $borrowernumber )->is_debarred;
495 return ( 1, $blockeddate ) if $blockeddate;
497 # if he have late issues
498 my $sth = $dbh->prepare(
499 "SELECT COUNT(*) as latedocs
501 WHERE borrowernumber = ?
502 AND date_due < now()"
504 $sth->execute($borrowernumber);
505 my $latedocs = $sth->fetchrow_hashref->{'latedocs'};
507 return ( -1, $latedocs ) if $latedocs > 0;
512 =head2 GetMemberIssuesAndFines
514 ($overdue_count, $issue_count, $total_fines) = &GetMemberIssuesAndFines($borrowernumber);
516 Returns aggregate data about items borrowed by the patron with the
517 given borrowernumber.
519 C<&GetMemberIssuesAndFines> returns a three-element array. C<$overdue_count> is the
520 number of overdue items the patron currently has borrowed. C<$issue_count> is the
521 number of books the patron currently has borrowed. C<$total_fines> is
522 the total fine currently due by the borrower.
527 sub GetMemberIssuesAndFines {
528 my ( $borrowernumber ) = @_;
529 my $dbh = C4::Context->dbh;
530 my $query = "SELECT COUNT(*) FROM issues WHERE borrowernumber = ?";
532 $debug and warn $query."\n";
533 my $sth = $dbh->prepare($query);
534 $sth->execute($borrowernumber);
535 my $issue_count = $sth->fetchrow_arrayref->[0];
537 $sth = $dbh->prepare(
538 "SELECT COUNT(*) FROM issues
539 WHERE borrowernumber = ?
540 AND date_due < now()"
542 $sth->execute($borrowernumber);
543 my $overdue_count = $sth->fetchrow_arrayref->[0];
545 $sth = $dbh->prepare("SELECT SUM(amountoutstanding) FROM accountlines WHERE borrowernumber = ?");
546 $sth->execute($borrowernumber);
547 my $total_fines = $sth->fetchrow_arrayref->[0];
549 return ($overdue_count, $issue_count, $total_fines);
555 my $success = ModMember(borrowernumber => $borrowernumber,
556 [ field => value ]... );
558 Modify borrower's data. All date fields should ALREADY be in ISO format.
561 true on success, or false on failure
567 # test to know if you must update or not the borrower password
568 if (exists $data{password}) {
569 if ($data{password} eq '****' or $data{password} eq '') {
570 delete $data{password};
572 if ( C4::Context->preference('NorwegianPatronDBEnable') && C4::Context->preference('NorwegianPatronDBEnable') == 1 ) {
573 # Update the hashed PIN in borrower_sync.hashed_pin, before Koha hashes it
574 Koha::NorwegianPatronDB::NLUpdateHashedPIN( $data{'borrowernumber'}, $data{password} );
576 $data{password} = hash_password($data{password});
580 my $old_categorycode = GetBorrowerCategorycode( $data{borrowernumber} );
582 # get only the columns of a borrower
583 my $schema = Koha::Database->new()->schema;
584 my @columns = $schema->source('Borrower')->columns;
585 my $new_borrower = { map { join(' ', @columns) =~ /$_/ ? ( $_ => $data{$_} ) : () } keys(%data) };
586 delete $new_borrower->{flags};
588 $new_borrower->{dateofbirth} ||= undef if exists $new_borrower->{dateofbirth};
589 $new_borrower->{dateenrolled} ||= undef if exists $new_borrower->{dateenrolled};
590 $new_borrower->{dateexpiry} ||= undef if exists $new_borrower->{dateexpiry};
591 $new_borrower->{debarred} ||= undef if exists $new_borrower->{debarred};
592 $new_borrower->{sms_provider_id} ||= undef if exists $new_borrower->{sms_provider_id};
594 my $rs = $schema->resultset('Borrower')->search({
595 borrowernumber => $new_borrower->{borrowernumber},
598 delete $new_borrower->{userid} if exists $new_borrower->{userid} and not $new_borrower->{userid};
600 my $execute_success = $rs->update($new_borrower);
601 if ($execute_success ne '0E0') { # only proceed if the update was a success
602 # If the patron changes to a category with enrollment fee, we add a fee
603 if ( $data{categorycode} and $data{categorycode} ne $old_categorycode ) {
604 if ( C4::Context->preference('FeeOnChangePatronCategory') ) {
605 AddEnrolmentFeeIfNeeded( $data{categorycode}, $data{borrowernumber} );
609 # If NorwegianPatronDBEnable is enabled, we set syncstatus to something that a
610 # cronjob will use for syncing with NL
611 if ( C4::Context->preference('NorwegianPatronDBEnable') && C4::Context->preference('NorwegianPatronDBEnable') == 1 ) {
612 my $borrowersync = Koha::Database->new->schema->resultset('BorrowerSync')->find({
613 'synctype' => 'norwegianpatrondb',
614 'borrowernumber' => $data{'borrowernumber'}
616 # Do not set to "edited" if syncstatus is "new". We need to sync as new before
617 # we can sync as changed. And the "new sync" will pick up all changes since
618 # the patron was created anyway.
619 if ( $borrowersync->syncstatus ne 'new' && $borrowersync->syncstatus ne 'delete' ) {
620 $borrowersync->update( { 'syncstatus' => 'edited' } );
622 # Set the value of 'sync'
623 $borrowersync->update( { 'sync' => $data{'sync'} } );
624 # Try to do the live sync
625 Koha::NorwegianPatronDB::NLSync({ 'borrowernumber' => $data{'borrowernumber'} });
628 logaction("MEMBERS", "MODIFY", $data{'borrowernumber'}, "UPDATE (executed w/ arg: $data{'borrowernumber'})") if C4::Context->preference("BorrowersLog");
630 return $execute_success;
635 $borrowernumber = &AddMember(%borrower);
637 insert new borrower into table
639 (%borrower keys are database columns. Database columns could be
640 different in different versions. Please look into database for correct
643 Returns the borrowernumber upon success
645 Returns as undef upon any db error without further processing
652 my $dbh = C4::Context->dbh;
653 my $schema = Koha::Database->new()->schema;
655 # generate a proper login if none provided
656 $data{'userid'} = Generate_Userid( $data{'borrowernumber'}, $data{'firstname'}, $data{'surname'} )
657 if ( $data{'userid'} eq '' || !Check_Userid( $data{'userid'} ) );
659 # add expiration date if it isn't already there
660 unless ( $data{'dateexpiry'} ) {
661 $data{'dateexpiry'} = GetExpiryDate( $data{'categorycode'}, output_pref( { dt => dt_from_string, dateonly => 1, dateformat => 'iso' } ) );
664 # add enrollment date if it isn't already there
665 unless ( $data{'dateenrolled'} ) {
666 $data{'dateenrolled'} = output_pref( { dt => dt_from_string, dateonly => 1, dateformat => 'iso' } );
669 my $patron_category = $schema->resultset('Category')->find( $data{'categorycode'} );
671 $patron_category->default_privacy() eq 'default' ? 1
672 : $patron_category->default_privacy() eq 'never' ? 2
673 : $patron_category->default_privacy() eq 'forever' ? 0
676 $data{'privacy_guarantor_checkouts'} = 0 unless defined( $data{'privacy_guarantor_checkouts'} );
678 # Make a copy of the plain text password for later use
679 my $plain_text_password = $data{'password'};
681 # create a disabled account if no password provided
682 $data{'password'} = ($data{'password'})? hash_password($data{'password'}) : '!';
684 # we don't want invalid dates in the db (mysql has a bad habit of inserting 0000-00-00
685 $data{'dateofbirth'} = undef if ( not $data{'dateofbirth'} );
686 $data{'debarred'} = undef if ( not $data{'debarred'} );
687 $data{'sms_provider_id'} = undef if ( not $data{'sms_provider_id'} );
689 # get only the columns of Borrower
690 my @columns = $schema->source('Borrower')->columns;
691 my $new_member = { map { join(' ',@columns) =~ /$_/ ? ( $_ => $data{$_} ) : () } keys(%data) } ;
692 $new_member->{checkprevcheckout} ||= 'inherit';
693 delete $new_member->{borrowernumber};
695 my $rs = $schema->resultset('Borrower');
696 $data{borrowernumber} = $rs->create($new_member)->id;
698 # If NorwegianPatronDBEnable is enabled, we set syncstatus to something that a
699 # cronjob will use for syncing with NL
700 if ( exists $data{'borrowernumber'} && C4::Context->preference('NorwegianPatronDBEnable') && C4::Context->preference('NorwegianPatronDBEnable') == 1 ) {
701 Koha::Database->new->schema->resultset('BorrowerSync')->create({
702 'borrowernumber' => $data{'borrowernumber'},
703 'synctype' => 'norwegianpatrondb',
705 'syncstatus' => 'new',
706 'hashed_pin' => Koha::NorwegianPatronDB::NLEncryptPIN( $plain_text_password ),
710 # mysql_insertid is probably bad. not necessarily accurate and mysql-specific at best.
711 logaction("MEMBERS", "CREATE", $data{'borrowernumber'}, "") if C4::Context->preference("BorrowersLog");
713 AddEnrolmentFeeIfNeeded( $data{categorycode}, $data{borrowernumber} );
715 return $data{borrowernumber};
720 my $uniqueness = Check_Userid($userid,$borrowernumber);
722 $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 != '').
724 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.
727 0 for not unique (i.e. this $userid already exists)
728 1 for unique (i.e. this $userid does not exist, or this $userid/$borrowernumber combination already exists)
733 my ( $uid, $borrowernumber ) = @_;
735 return 0 unless ($uid); # userid is a unique column, we should assume NULL is not unique
737 return 0 if ( $uid eq C4::Context->config('user') );
739 my $rs = Koha::Database->new()->schema()->resultset('Borrower');
742 $params->{userid} = $uid;
743 $params->{borrowernumber} = { '!=' => $borrowernumber } if ($borrowernumber);
745 my $count = $rs->count( $params );
747 return $count ? 0 : 1;
750 =head2 Generate_Userid
752 my $newuid = Generate_Userid($borrowernumber, $firstname, $surname);
754 Generate a userid using the $surname and the $firstname (if there is a value in $firstname).
756 $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.
759 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).
763 sub Generate_Userid {
764 my ($borrowernumber, $firstname, $surname) = @_;
767 #The script will "do" the following code and increment the $offset until Check_Userid = 1 (i.e. until $newuid comes back as unique)
769 $firstname =~ s/[[:digit:][:space:][:blank:][:punct:][:cntrl:]]//g;
770 $surname =~ s/[[:digit:][:space:][:blank:][:punct:][:cntrl:]]//g;
771 $newuid = lc(($firstname)? "$firstname.$surname" : $surname);
772 $newuid = unac_string('utf-8',$newuid);
773 $newuid .= $offset unless $offset == 0;
776 } while (!Check_Userid($newuid,$borrowernumber));
781 =head2 fixup_cardnumber
783 Warning: The caller is responsible for locking the members table in write
784 mode, to avoid database corruption.
788 use vars qw( @weightings );
789 my @weightings = ( 8, 4, 6, 3, 5, 2, 1 );
791 sub fixup_cardnumber {
792 my ($cardnumber) = @_;
793 my $autonumber_members = C4::Context->boolean_preference('autoMemberNum') || 0;
795 # Find out whether member numbers should be generated
796 # automatically. Should be either "1" or something else.
797 # Defaults to "0", which is interpreted as "no".
799 # if ($cardnumber !~ /\S/ && $autonumber_members) {
800 ($autonumber_members) or return $cardnumber;
801 my $checkdigit = C4::Context->preference('checkdigit');
802 my $dbh = C4::Context->dbh;
803 if ( $checkdigit and $checkdigit eq 'katipo' ) {
805 # if checkdigit is selected, calculate katipo-style cardnumber.
806 # otherwise, just use the max()
807 # purpose: generate checksum'd member numbers.
808 # We'll assume we just got the max value of digits 2-8 of member #'s
809 # from the database and our job is to increment that by one,
810 # determine the 1st and 9th digits and return the full string.
811 my $sth = $dbh->prepare(
812 "select max(substring(borrowers.cardnumber,2,7)) as new_num from borrowers"
815 my $data = $sth->fetchrow_hashref;
816 $cardnumber = $data->{new_num};
817 if ( !$cardnumber ) { # If DB has no values,
818 $cardnumber = 1000000; # start at 1000000
824 for ( my $i = 0 ; $i < 8 ; $i += 1 ) {
825 # read weightings, left to right, 1 char at a time
826 my $temp1 = $weightings[$i];
828 # sequence left to right, 1 char at a time
829 my $temp2 = substr( $cardnumber, $i, 1 );
831 # mult each char 1-7 by its corresponding weighting
832 $sum += $temp1 * $temp2;
835 my $rem = ( $sum % 11 );
836 $rem = 'X' if $rem == 10;
838 return "V$cardnumber$rem";
841 my $sth = $dbh->prepare(
842 'SELECT MAX( CAST( cardnumber AS SIGNED ) ) FROM borrowers WHERE cardnumber REGEXP "^-?[0-9]+$"'
845 my ($result) = $sth->fetchrow;
848 return $cardnumber; # just here as a fallback/reminder
851 =head2 GetPendingIssues
853 my $issues = &GetPendingIssues(@borrowernumber);
855 Looks up what the patron with the given borrowernumber has borrowed.
857 C<&GetPendingIssues> returns a
858 reference-to-array where each element is a reference-to-hash; the
859 keys are the fields from the C<issues>, C<biblio>, and C<items> tables.
860 The keys include C<biblioitems> fields except marc and marcxml.
864 sub GetPendingIssues {
865 my @borrowernumbers = @_;
867 unless (@borrowernumbers ) { # return a ref_to_array
868 return \@borrowernumbers; # to not cause surprise to caller
871 # Borrowers part of the query
873 for (my $i = 0; $i < @borrowernumbers; $i++) {
874 $bquery .= ' issues.borrowernumber = ?';
875 if ($i < $#borrowernumbers ) {
880 # must avoid biblioitems.* to prevent large marc and marcxml fields from killing performance
881 # FIXME: namespace collision: each table has "timestamp" fields. Which one is "timestamp" ?
882 # FIXME: circ/ciculation.pl tries to sort by timestamp!
883 # FIXME: namespace collision: other collisions possible.
884 # FIXME: most of this data isn't really being used by callers.
891 biblioitems.itemtype,
894 biblioitems.publicationyear,
895 biblioitems.publishercode,
896 biblioitems.volumedate,
897 biblioitems.volumedesc,
902 borrowers.cardnumber,
903 issues.timestamp AS timestamp,
904 issues.renewals AS renewals,
905 issues.borrowernumber AS borrowernumber,
906 items.renewals AS totalrenewals
908 LEFT JOIN items ON items.itemnumber = issues.itemnumber
909 LEFT JOIN biblio ON items.biblionumber = biblio.biblionumber
910 LEFT JOIN biblioitems ON items.biblioitemnumber = biblioitems.biblioitemnumber
911 LEFT JOIN borrowers ON issues.borrowernumber = borrowers.borrowernumber
914 ORDER BY issues.issuedate"
917 my $sth = C4::Context->dbh->prepare($query);
918 $sth->execute(@borrowernumbers);
919 my $data = $sth->fetchall_arrayref({});
920 my $today = dt_from_string;
922 if ($_->{issuedate}) {
923 $_->{issuedate} = dt_from_string($_->{issuedate}, 'sql');
925 $_->{date_due_sql} = $_->{date_due};
926 # FIXME no need to have this value
927 $_->{date_due} or next;
928 $_->{date_due_sql} = $_->{date_due};
929 # FIXME no need to have this value
930 $_->{date_due} = dt_from_string($_->{date_due}, 'sql');
931 if ( DateTime->compare($_->{date_due}, $today) == -1 ) {
940 $issues = &GetAllIssues($borrowernumber, $sortkey, $limit);
942 Looks up what the patron with the given borrowernumber has borrowed,
943 and sorts the results.
945 C<$sortkey> is the name of a field on which to sort the results. This
946 should be the name of a field in the C<issues>, C<biblio>,
947 C<biblioitems>, or C<items> table in the Koha database.
949 C<$limit> is the maximum number of results to return.
951 C<&GetAllIssues> an arrayref, C<$issues>, of hashrefs, the keys of which
952 are the fields from the C<issues>, C<biblio>, C<biblioitems>, and
953 C<items> tables of the Koha database.
959 my ( $borrowernumber, $order, $limit ) = @_;
961 return unless $borrowernumber;
962 $order = 'date_due desc' unless $order;
964 my $dbh = C4::Context->dbh;
966 'SELECT *, issues.timestamp as issuestimestamp, issues.renewals AS renewals,items.renewals AS totalrenewals,items.timestamp AS itemstimestamp
968 LEFT JOIN items on items.itemnumber=issues.itemnumber
969 LEFT JOIN biblio ON items.biblionumber=biblio.biblionumber
970 LEFT JOIN biblioitems ON items.biblioitemnumber=biblioitems.biblioitemnumber
971 WHERE borrowernumber=?
973 SELECT *, old_issues.timestamp as issuestimestamp, old_issues.renewals AS renewals,items.renewals AS totalrenewals,items.timestamp AS itemstimestamp
975 LEFT JOIN items on items.itemnumber=old_issues.itemnumber
976 LEFT JOIN biblio ON items.biblionumber=biblio.biblionumber
977 LEFT JOIN biblioitems ON items.biblioitemnumber=biblioitems.biblioitemnumber
978 WHERE borrowernumber=? AND old_issues.itemnumber IS NOT NULL
981 $query .= " limit $limit";
984 my $sth = $dbh->prepare($query);
985 $sth->execute( $borrowernumber, $borrowernumber );
986 return $sth->fetchall_arrayref( {} );
990 =head2 GetMemberAccountRecords
992 ($total, $acctlines, $count) = &GetMemberAccountRecords($borrowernumber);
994 Looks up accounting data for the patron with the given borrowernumber.
996 C<&GetMemberAccountRecords> returns a three-element array. C<$acctlines> is a
997 reference-to-array, where each element is a reference-to-hash; the
998 keys are the fields of the C<accountlines> table in the Koha database.
999 C<$count> is the number of elements in C<$acctlines>. C<$total> is the
1000 total amount outstanding for all of the account lines.
1004 sub GetMemberAccountRecords {
1005 my ($borrowernumber) = @_;
1006 my $dbh = C4::Context->dbh;
1012 WHERE borrowernumber=?);
1013 $strsth.=" ORDER BY accountlines_id desc";
1014 my $sth= $dbh->prepare( $strsth );
1015 $sth->execute( $borrowernumber );
1018 while ( my $data = $sth->fetchrow_hashref ) {
1019 if ( $data->{itemnumber} ) {
1020 my $biblio = GetBiblioFromItemNumber( $data->{itemnumber} );
1021 $data->{biblionumber} = $biblio->{biblionumber};
1022 $data->{title} = $biblio->{title};
1024 $acctlines[$numlines] = $data;
1026 $total += sprintf "%.0f", 1000*$data->{amountoutstanding}; # convert float to integer to avoid round-off errors
1029 return ( $total, \@acctlines,$numlines);
1032 =head2 GetMemberAccountBalance
1034 ($total_balance, $non_issue_balance, $other_charges) = &GetMemberAccountBalance($borrowernumber);
1036 Calculates amount immediately owing by the patron - non-issue charges.
1037 Based on GetMemberAccountRecords.
1038 Charges exempt from non-issue are:
1040 * Rent (rental) if RentalsInNoissuesCharge syspref is set to false
1041 * Manual invoices if ManInvInNoissuesCharge syspref is set to false
1045 sub GetMemberAccountBalance {
1046 my ($borrowernumber) = @_;
1048 my $ACCOUNT_TYPE_LENGTH = 5; # this is plain ridiculous...
1051 push @not_fines, 'Res' unless C4::Context->preference('HoldsInNoissuesCharge');
1052 push @not_fines, 'Rent' unless C4::Context->preference('RentalsInNoissuesCharge');
1053 unless ( C4::Context->preference('ManInvInNoissuesCharge') ) {
1054 my $dbh = C4::Context->dbh;
1055 my $man_inv_types = $dbh->selectcol_arrayref(qq{SELECT authorised_value FROM authorised_values WHERE category = 'MANUAL_INV'});
1056 push @not_fines, map substr($_, 0, $ACCOUNT_TYPE_LENGTH), @$man_inv_types;
1058 my %not_fine = map {$_ => 1} @not_fines;
1060 my ($total, $acctlines) = GetMemberAccountRecords($borrowernumber);
1061 my $other_charges = 0;
1062 foreach (@$acctlines) {
1063 $other_charges += $_->{amountoutstanding} if $not_fine{ substr($_->{accounttype}, 0, $ACCOUNT_TYPE_LENGTH) };
1066 return ( $total, $total - $other_charges, $other_charges);
1069 =head2 GetBorNotifyAcctRecord
1071 ($total, $acctlines, $count) = &GetBorNotifyAcctRecord($params,$notifyid);
1073 Looks up accounting data for the patron with the given borrowernumber per file number.
1075 C<&GetBorNotifyAcctRecord> returns a three-element array. C<$acctlines> is a
1076 reference-to-array, where each element is a reference-to-hash; the
1077 keys are the fields of the C<accountlines> table in the Koha database.
1078 C<$count> is the number of elements in C<$acctlines>. C<$total> is the
1079 total amount outstanding for all of the account lines.
1083 sub GetBorNotifyAcctRecord {
1084 my ( $borrowernumber, $notifyid ) = @_;
1085 my $dbh = C4::Context->dbh;
1088 my $sth = $dbh->prepare(
1091 WHERE borrowernumber=?
1093 AND amountoutstanding != '0'
1094 ORDER BY notify_id,accounttype
1097 $sth->execute( $borrowernumber, $notifyid );
1099 while ( my $data = $sth->fetchrow_hashref ) {
1100 if ( $data->{itemnumber} ) {
1101 my $biblio = GetBiblioFromItemNumber( $data->{itemnumber} );
1102 $data->{biblionumber} = $biblio->{biblionumber};
1103 $data->{title} = $biblio->{title};
1105 $acctlines[$numlines] = $data;
1107 $total += int(100 * $data->{'amountoutstanding'});
1110 return ( $total, \@acctlines, $numlines );
1113 sub checkcardnumber {
1114 my ( $cardnumber, $borrowernumber ) = @_;
1116 # If cardnumber is null, we assume they're allowed.
1117 return 0 unless defined $cardnumber;
1119 my $dbh = C4::Context->dbh;
1120 my $query = "SELECT * FROM borrowers WHERE cardnumber=?";
1121 $query .= " AND borrowernumber <> ?" if ($borrowernumber);
1122 my $sth = $dbh->prepare($query);
1125 ( $borrowernumber ? $borrowernumber : () )
1128 return 1 if $sth->fetchrow_hashref;
1130 my ( $min_length, $max_length ) = get_cardnumber_length();
1132 if length $cardnumber > $max_length
1133 or length $cardnumber < $min_length;
1138 =head2 get_cardnumber_length
1140 my ($min, $max) = C4::Members::get_cardnumber_length()
1142 Returns the minimum and maximum length for patron cardnumbers as
1143 determined by the CardnumberLength system preference, the
1144 BorrowerMandatoryField system preference, and the width of the
1149 sub get_cardnumber_length {
1150 my ( $min, $max ) = ( 0, 16 ); # borrowers.cardnumber is a nullable varchar(16)
1151 $min = 1 if C4::Context->preference('BorrowerMandatoryField') =~ /cardnumber/;
1152 if ( my $cardnumber_length = C4::Context->preference('CardnumberLength') ) {
1153 # Is integer and length match
1154 if ( $cardnumber_length =~ m|^\d+$| ) {
1155 $min = $max = $cardnumber_length
1156 if $cardnumber_length >= $min
1157 and $cardnumber_length <= $max;
1159 # Else assuming it is a range
1160 elsif ( $cardnumber_length =~ m|(\d*),(\d*)| ) {
1161 $min = $1 if $1 and $min < $1;
1162 $max = $2 if $2 and $max > $2;
1166 return ( $min, $max );
1169 =head2 GetFirstValidEmailAddress
1171 $email = GetFirstValidEmailAddress($borrowernumber);
1173 Return the first valid email address for a borrower, given the borrowernumber. For now, the order
1174 is defined as email, emailpro, B_email. Returns the empty string if the borrower has no email
1179 sub GetFirstValidEmailAddress {
1180 my $borrowernumber = shift;
1181 my $dbh = C4::Context->dbh;
1182 my $sth = $dbh->prepare( "SELECT email, emailpro, B_email FROM borrowers where borrowernumber = ? ");
1183 $sth->execute( $borrowernumber );
1184 my $data = $sth->fetchrow_hashref;
1186 if ($data->{'email'}) {
1187 return $data->{'email'};
1188 } elsif ($data->{'emailpro'}) {
1189 return $data->{'emailpro'};
1190 } elsif ($data->{'B_email'}) {
1191 return $data->{'B_email'};
1197 =head2 GetNoticeEmailAddress
1199 $email = GetNoticeEmailAddress($borrowernumber);
1201 Return the email address of borrower used for notices, given the borrowernumber.
1202 Returns the empty string if no email address.
1206 sub GetNoticeEmailAddress {
1207 my $borrowernumber = shift;
1209 my $which_address = C4::Context->preference("AutoEmailPrimaryAddress");
1210 # if syspref is set to 'first valid' (value == OFF), look up email address
1211 if ( $which_address eq 'OFF' ) {
1212 return GetFirstValidEmailAddress($borrowernumber);
1214 # specified email address field
1215 my $dbh = C4::Context->dbh;
1216 my $sth = $dbh->prepare( qq{
1217 SELECT $which_address AS primaryemail
1219 WHERE borrowernumber=?
1221 $sth->execute($borrowernumber);
1222 my $data = $sth->fetchrow_hashref;
1223 return $data->{'primaryemail'} || '';
1226 =head2 GetExpiryDate
1228 $expirydate = GetExpiryDate($categorycode, $dateenrolled);
1230 Calculate expiry date given a categorycode and starting date. Date argument must be in ISO format.
1231 Return date is also in ISO format.
1236 my ( $categorycode, $dateenrolled ) = @_;
1238 if ($categorycode) {
1239 my $dbh = C4::Context->dbh;
1240 my $sth = $dbh->prepare("SELECT enrolmentperiod,enrolmentperioddate FROM categories WHERE categorycode=?");
1241 $sth->execute($categorycode);
1242 $enrolments = $sth->fetchrow_hashref;
1244 # die "GetExpiryDate: for enrollmentperiod $enrolmentperiod (category '$categorycode') starting $dateenrolled.\n";
1245 my @date = split (/-/,$dateenrolled);
1246 if($enrolments->{enrolmentperiod}){
1247 return sprintf("%04d-%02d-%02d", Add_Delta_YM(@date,0,$enrolments->{enrolmentperiod}));
1249 return $enrolments->{enrolmentperioddate};
1253 =head2 GetUpcomingMembershipExpires
1255 my $expires = GetUpcomingMembershipExpires({
1256 branch => $branch, before => $before, after => $after,
1259 $branch is an optional branch code.
1260 $before/$after is an optional number of days before/after the date that
1261 is set by the preference MembershipExpiryDaysNotice.
1262 If the pref would be 14, before 2 and after 3, you will get all expires
1267 sub GetUpcomingMembershipExpires {
1268 my ( $params ) = @_;
1269 my $before = $params->{before} || 0;
1270 my $after = $params->{after} || 0;
1271 my $branch = $params->{branch};
1273 my $dbh = C4::Context->dbh;
1274 my $days = C4::Context->preference("MembershipExpiryDaysNotice") || 0;
1275 my $date1 = dt_from_string->add( days => $days - $before );
1276 my $date2 = dt_from_string->add( days => $days + $after );
1277 $date1= output_pref({ dt => $date1, dateformat => 'iso', dateonly => 1 });
1278 $date2= output_pref({ dt => $date2, dateformat => 'iso', dateonly => 1 });
1281 SELECT borrowers.*, categories.description,
1282 branches.branchname, branches.branchemail FROM borrowers
1283 LEFT JOIN branches USING (branchcode)
1284 LEFT JOIN categories USING (categorycode)
1287 $query.= 'WHERE branchcode=? AND dateexpiry BETWEEN ? AND ?';
1289 $query.= 'WHERE dateexpiry BETWEEN ? AND ?';
1292 my $sth = $dbh->prepare( $query );
1293 my @pars = $branch? ( $branch ): ();
1294 push @pars, $date1, $date2;
1295 $sth->execute( @pars );
1296 my $results = $sth->fetchall_arrayref( {} );
1300 =head2 GetborCatFromCatType
1302 ($codes_arrayref, $labels_hashref) = &GetborCatFromCatType();
1304 Looks up the different types of borrowers in the database. Returns two
1305 elements: a reference-to-array, which lists the borrower category
1306 codes, and a reference-to-hash, which maps the borrower category codes
1307 to category descriptions.
1312 sub GetborCatFromCatType {
1313 my ( $category_type, $action, $no_branch_limit ) = @_;
1315 my $branch_limit = $no_branch_limit
1317 : C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1319 # FIXME - This API seems both limited and dangerous.
1320 my $dbh = C4::Context->dbh;
1323 SELECT DISTINCT categories.categorycode, categories.description
1327 LEFT JOIN categories_branches ON categories.categorycode = categories_branches.categorycode
1330 $request .= " $action ";
1331 $request .= " AND (branchcode = ? OR branchcode IS NULL)" if $branch_limit;
1333 $request .= " WHERE branchcode = ? OR branchcode IS NULL" if $branch_limit;
1335 $request .= " ORDER BY categorycode";
1337 my $sth = $dbh->prepare($request);
1339 $action ? $category_type : (),
1340 $branch_limit ? $branch_limit : ()
1346 while ( my $data = $sth->fetchrow_hashref ) {
1347 push @codes, $data->{'categorycode'};
1348 $labels{ $data->{'categorycode'} } = $data->{'description'};
1351 return ( \@codes, \%labels );
1354 =head2 GetBorrowercategory
1356 $hashref = &GetBorrowercategory($categorycode);
1358 Given the borrower's category code, the function returns the corresponding
1359 data hashref for a comprehensive information display.
1363 sub GetBorrowercategory {
1365 my $dbh = C4::Context->dbh;
1369 "SELECT description,dateofbirthrequired,upperagelimit,category_type
1371 WHERE categorycode = ?"
1373 $sth->execute($catcode);
1375 $sth->fetchrow_hashref;
1379 } # sub getborrowercategory
1382 =head2 GetBorrowerCategorycode
1384 $categorycode = &GetBorrowerCategoryCode( $borrowernumber );
1386 Given the borrowernumber, the function returns the corresponding categorycode
1390 sub GetBorrowerCategorycode {
1391 my ( $borrowernumber ) = @_;
1392 my $dbh = C4::Context->dbh;
1393 my $sth = $dbh->prepare( qq{
1396 WHERE borrowernumber = ?
1398 $sth->execute( $borrowernumber );
1399 return $sth->fetchrow;
1402 =head2 GetBorrowercategoryList
1404 $arrayref_hashref = &GetBorrowercategoryList;
1405 If no category code provided, the function returns all the categories.
1409 sub GetBorrowercategoryList {
1410 my $no_branch_limit = @_ ? shift : 0;
1411 my $branch_limit = $no_branch_limit
1413 : C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1414 my $dbh = C4::Context->dbh;
1415 my $query = "SELECT categories.* FROM categories";
1417 LEFT JOIN categories_branches ON categories.categorycode = categories_branches.categorycode
1418 WHERE branchcode = ? OR branchcode IS NULL GROUP BY description
1420 $query .= " ORDER BY description";
1421 my $sth = $dbh->prepare( $query );
1422 $sth->execute( $branch_limit ? $branch_limit : () );
1423 my $data = $sth->fetchall_arrayref( {} );
1426 } # sub getborrowercategory
1430 $dateofbirth,$date = &GetAge($date);
1432 this function return the borrowers age with the value of dateofbirth
1438 my ( $date, $date_ref ) = @_;
1440 if ( not defined $date_ref ) {
1441 $date_ref = sprintf( '%04d-%02d-%02d', Today() );
1444 my ( $year1, $month1, $day1 ) = split /-/, $date;
1445 my ( $year2, $month2, $day2 ) = split /-/, $date_ref;
1447 my $age = $year2 - $year1;
1448 if ( $month1 . $day1 > $month2 . $day2 ) {
1457 $borrower = C4::Members::SetAge($borrower, $datetimeduration);
1458 $borrower = C4::Members::SetAge($borrower, '0015-12-10');
1459 $borrower = C4::Members::SetAge($borrower, $datetimeduration, $datetime_reference);
1461 eval { $borrower = C4::Members::SetAge($borrower, '015-1-10'); };
1462 if ($@) {print $@;} #Catch a bad ISO Date or kill your script!
1464 This function sets the borrower's dateofbirth to match the given age.
1465 Optionally relative to the given $datetime_reference.
1467 @PARAM1 koha.borrowers-object
1468 @PARAM2 DateTime::Duration-object as the desired age
1469 OR a ISO 8601 Date. (To make the API more pleasant)
1470 @PARAM3 DateTime-object as the relative date, defaults to now().
1471 RETURNS The given borrower reference @PARAM1.
1472 DIES If there was an error with the ISO Date handling.
1478 my ( $borrower, $datetimeduration, $datetime_ref ) = @_;
1479 $datetime_ref = DateTime->now() unless $datetime_ref;
1481 if ($datetimeduration && ref $datetimeduration ne 'DateTime::Duration') {
1482 if ($datetimeduration =~ /^(\d{4})-(\d{2})-(\d{2})/) {
1483 $datetimeduration = DateTime::Duration->new(years => $1, months => $2, days => $3);
1486 die "C4::Members::SetAge($borrower, $datetimeduration), datetimeduration not a valid ISO 8601 Date!\n";
1490 my $new_datetime_ref = $datetime_ref->clone();
1491 $new_datetime_ref->subtract_duration( $datetimeduration );
1493 $borrower->{dateofbirth} = $new_datetime_ref->ymd();
1498 =head2 GetSortDetails (OUEST-PROVENCE)
1500 ($lib) = &GetSortDetails($category,$sortvalue);
1502 Returns the authorized value details
1503 C<&$lib>return value of authorized value details
1504 C<&$sortvalue>this is the value of authorized value
1505 C<&$category>this is the value of authorized value category
1509 sub GetSortDetails {
1510 my ( $category, $sortvalue ) = @_;
1511 my $dbh = C4::Context->dbh;
1512 my $query = qq|SELECT lib
1513 FROM authorised_values
1515 AND authorised_value=? |;
1516 my $sth = $dbh->prepare($query);
1517 $sth->execute( $category, $sortvalue );
1518 my $lib = $sth->fetchrow;
1519 return ($lib) if ($lib);
1520 return ($sortvalue) unless ($lib);
1523 =head2 MoveMemberToDeleted
1525 $result = &MoveMemberToDeleted($borrowernumber);
1527 Copy the record from borrowers to deletedborrowers table.
1528 The routine returns 1 for success, undef for failure.
1532 sub MoveMemberToDeleted {
1533 my ($member) = shift or return;
1535 my $schema = Koha::Database->new()->schema();
1536 my $borrowers_rs = $schema->resultset('Borrower');
1537 $borrowers_rs->result_class('DBIx::Class::ResultClass::HashRefInflator');
1538 my $borrower = $borrowers_rs->find($member);
1539 return unless $borrower;
1541 my $deleted = $schema->resultset('Deletedborrower')->create($borrower);
1543 return $deleted ? 1 : undef;
1548 DelMember($borrowernumber);
1550 This function remove directly a borrower whitout writing it on deleteborrower.
1551 + Deletes reserves for the borrower
1556 my $dbh = C4::Context->dbh;
1557 my $borrowernumber = shift;
1558 #warn "in delmember with $borrowernumber";
1559 return unless $borrowernumber; # borrowernumber is mandatory.
1560 # Delete Patron's holds
1561 my @holds = Koha::Holds->search({ borrowernumber => $borrowernumber });
1562 $_->delete for @holds;
1567 WHERE borrowernumber = ?
1569 my $sth = $dbh->prepare($query);
1570 $sth->execute($borrowernumber);
1571 logaction("MEMBERS", "DELETE", $borrowernumber, "") if C4::Context->preference("BorrowersLog");
1575 =head2 HandleDelBorrower
1577 HandleDelBorrower($borrower);
1579 When a member is deleted (DelMember in Members.pm), you should call me first.
1580 This routine deletes/moves lists and entries for the deleted member/borrower.
1581 Lists owned by the borrower are deleted, but entries from the borrower to
1582 other lists are kept.
1586 sub HandleDelBorrower {
1589 my $dbh = C4::Context->dbh;
1591 #Delete all lists and all shares of this borrower
1592 #Consistent with the approach Koha uses on deleting individual lists
1593 #Note that entries in virtualshelfcontents added by this borrower to
1594 #lists of others will be handled by a table constraint: the borrower
1595 #is set to NULL in those entries.
1596 $query="DELETE FROM virtualshelves WHERE owner=?";
1597 $dbh->do($query,undef,($borrower));
1600 #We could handle the above deletes via a constraint too.
1601 #But a new BZ report 11889 has been opened to discuss another approach.
1602 #Instead of deleting we could also disown lists (based on a pref).
1603 #In that way we could save shared and public lists.
1604 #The current table constraints support that idea now.
1605 #This pref should then govern the results of other routines/methods such as
1606 #Koha::Virtualshelf->new->delete too.
1609 =head2 ExtendMemberSubscriptionTo (OUEST-PROVENCE)
1611 $date = ExtendMemberSubscriptionTo($borrowerid, $date);
1613 Extending the subscription to a given date or to the expiry date calculated on ISO date.
1618 sub ExtendMemberSubscriptionTo {
1619 my ( $borrowerid,$date) = @_;
1620 my $dbh = C4::Context->dbh;
1621 my $borrower = GetMember('borrowernumber'=>$borrowerid);
1623 $date = (C4::Context->preference('BorrowerRenewalPeriodBase') eq 'dateexpiry') ?
1624 eval { output_pref( { dt => dt_from_string( $borrower->{'dateexpiry'} ), dateonly => 1, dateformat => 'iso' } ); }
1626 output_pref( { dt => dt_from_string, dateonly => 1, dateformat => 'iso' } );
1627 $date = GetExpiryDate( $borrower->{'categorycode'}, $date );
1629 my $sth = $dbh->do(<<EOF);
1631 SET dateexpiry='$date'
1632 WHERE borrowernumber='$borrowerid'
1635 AddEnrolmentFeeIfNeeded( $borrower->{categorycode}, $borrower->{borrowernumber} );
1637 logaction("MEMBERS", "RENEW", $borrower->{'borrowernumber'}, "Membership renewed")if C4::Context->preference("BorrowersLog");
1638 return $date if ($sth);
1642 =head2 GetHideLostItemsPreference
1644 $hidelostitemspref = &GetHideLostItemsPreference($borrowernumber);
1646 Returns the HideLostItems preference for the patron category of the supplied borrowernumber
1647 C<&$hidelostitemspref>return value of function, 0 or 1
1651 sub GetHideLostItemsPreference {
1652 my ($borrowernumber) = @_;
1653 my $dbh = C4::Context->dbh;
1654 my $query = "SELECT hidelostitems FROM borrowers,categories WHERE borrowers.categorycode = categories.categorycode AND borrowernumber = ?";
1655 my $sth = $dbh->prepare($query);
1656 $sth->execute($borrowernumber);
1657 my $hidelostitems = $sth->fetchrow;
1658 return $hidelostitems;
1661 =head2 GetBorrowersToExpunge
1663 $borrowers = &GetBorrowersToExpunge(
1664 not_borrowed_since => $not_borrowed_since,
1665 expired_before => $expired_before,
1666 category_code => $category_code,
1667 patron_list_id => $patron_list_id,
1668 branchcode => $branchcode
1671 This function get all borrowers based on the given criteria.
1675 sub GetBorrowersToExpunge {
1678 my $filterdate = $params->{'not_borrowed_since'};
1679 my $filterexpiry = $params->{'expired_before'};
1680 my $filtercategory = $params->{'category_code'};
1681 my $filterbranch = $params->{'branchcode'} ||
1682 ((C4::Context->preference('IndependentBranches')
1683 && C4::Context->userenv
1684 && !C4::Context->IsSuperLibrarian()
1685 && C4::Context->userenv->{branch})
1686 ? C4::Context->userenv->{branch}
1688 my $filterpatronlist = $params->{'patron_list_id'};
1690 my $dbh = C4::Context->dbh;
1692 SELECT borrowers.borrowernumber,
1693 MAX(old_issues.timestamp) AS latestissue,
1694 MAX(issues.timestamp) AS currentissue
1696 JOIN categories USING (categorycode)
1700 WHERE guarantorid IS NOT NULL
1701 AND guarantorid <> 0
1702 ) as tmp ON borrowers.borrowernumber=tmp.guarantorid
1703 LEFT JOIN old_issues USING (borrowernumber)
1704 LEFT JOIN issues USING (borrowernumber)|;
1705 if ( $filterpatronlist ){
1706 $query .= q| LEFT JOIN patron_list_patrons USING (borrowernumber)|;
1708 $query .= q| WHERE category_type <> 'S'
1709 AND tmp.guarantorid IS NULL
1712 if ( $filterbranch && $filterbranch ne "" ) {
1713 $query.= " AND borrowers.branchcode = ? ";
1714 push( @query_params, $filterbranch );
1716 if ( $filterexpiry ) {
1717 $query .= " AND dateexpiry < ? ";
1718 push( @query_params, $filterexpiry );
1720 if ( $filtercategory ) {
1721 $query .= " AND categorycode = ? ";
1722 push( @query_params, $filtercategory );
1724 if ( $filterpatronlist ){
1725 $query.=" AND patron_list_id = ? ";
1726 push( @query_params, $filterpatronlist );
1728 $query.=" GROUP BY borrowers.borrowernumber HAVING currentissue IS NULL ";
1729 if ( $filterdate ) {
1730 $query.=" AND ( latestissue < ? OR latestissue IS NULL ) ";
1731 push @query_params,$filterdate;
1733 warn $query if $debug;
1735 my $sth = $dbh->prepare($query);
1736 if (scalar(@query_params)>0){
1737 $sth->execute(@query_params);
1744 while ( my $data = $sth->fetchrow_hashref ) {
1745 push @results, $data;
1750 =head2 GetBorrowersWhoHaveNeverBorrowed
1752 $results = &GetBorrowersWhoHaveNeverBorrowed
1754 This function get all borrowers who have never borrowed.
1756 I<$result> is a ref to an array which all elements are a hasref.
1760 sub GetBorrowersWhoHaveNeverBorrowed {
1761 my $filterbranch = shift ||
1762 ((C4::Context->preference('IndependentBranches')
1763 && C4::Context->userenv
1764 && !C4::Context->IsSuperLibrarian()
1765 && C4::Context->userenv->{branch})
1766 ? C4::Context->userenv->{branch}
1768 my $dbh = C4::Context->dbh;
1770 SELECT borrowers.borrowernumber,max(timestamp) as latestissue
1772 LEFT JOIN issues ON borrowers.borrowernumber = issues.borrowernumber
1773 WHERE issues.borrowernumber IS NULL
1776 if ($filterbranch && $filterbranch ne ""){
1777 $query.=" AND borrowers.branchcode= ?";
1778 push @query_params,$filterbranch;
1780 warn $query if $debug;
1782 my $sth = $dbh->prepare($query);
1783 if (scalar(@query_params)>0){
1784 $sth->execute(@query_params);
1791 while ( my $data = $sth->fetchrow_hashref ) {
1792 push @results, $data;
1797 =head2 GetBorrowersWithIssuesHistoryOlderThan
1799 $results = &GetBorrowersWithIssuesHistoryOlderThan($date)
1801 this function get all borrowers who has an issue history older than I<$date> given on input arg.
1803 I<$result> is a ref to an array which all elements are a hashref.
1804 This hashref is containt the number of time this borrowers has borrowed before I<$date> and the borrowernumber.
1808 sub GetBorrowersWithIssuesHistoryOlderThan {
1809 my $dbh = C4::Context->dbh;
1810 my $date = shift ||POSIX::strftime("%Y-%m-%d",localtime());
1811 my $filterbranch = shift ||
1812 ((C4::Context->preference('IndependentBranches')
1813 && C4::Context->userenv
1814 && !C4::Context->IsSuperLibrarian()
1815 && C4::Context->userenv->{branch})
1816 ? C4::Context->userenv->{branch}
1819 SELECT count(borrowernumber) as n,borrowernumber
1821 WHERE returndate < ?
1822 AND borrowernumber IS NOT NULL
1825 push @query_params, $date;
1827 $query.=" AND branchcode = ?";
1828 push @query_params, $filterbranch;
1830 $query.=" GROUP BY borrowernumber ";
1831 warn $query if $debug;
1832 my $sth = $dbh->prepare($query);
1833 $sth->execute(@query_params);
1836 while ( my $data = $sth->fetchrow_hashref ) {
1837 push @results, $data;
1844 IssueSlip($branchcode, $borrowernumber, $quickslip)
1846 Returns letter hash ( see C4::Letters::GetPreparedLetter )
1848 $quickslip is boolean, to indicate whether we want a quick slip
1850 IssueSlip populates ISSUESLIP and ISSUEQSLIP, and will make the following expansions:
1886 NOTE: Not all table fields are available, pleasee see GetPendingIssues for a list of available fields.
1891 my ($branch, $borrowernumber, $quickslip) = @_;
1893 # FIXME Check callers before removing this statement
1894 #return unless $borrowernumber;
1896 my @issues = @{ GetPendingIssues($borrowernumber) };
1898 for my $issue (@issues) {
1899 $issue->{date_due} = $issue->{date_due_sql};
1901 my $today = output_pref({ dt => dt_from_string, dateformat => 'iso', dateonly => 1 });
1902 if ( substr( $issue->{issuedate}, 0, 10 ) eq $today
1903 or substr( $issue->{lastreneweddate}, 0, 10 ) eq $today ) {
1909 # Sort on timestamp then on issuedate (useful for tests and could be if modified in a batch
1911 my $s = $b->{timestamp} <=> $a->{timestamp};
1913 $b->{issuedate} <=> $a->{issuedate} : $s;
1916 my ($letter_code, %repeat);
1918 $letter_code = 'ISSUEQSLIP';
1920 'checkedout' => [ map {
1923 'biblioitems' => $_,
1925 }, grep { $_->{'now'} } @issues ],
1929 $letter_code = 'ISSUESLIP';
1931 'checkedout' => [ map {
1934 'biblioitems' => $_,
1936 }, grep { !$_->{'overdue'} } @issues ],
1938 'overdue' => [ map {
1941 'biblioitems' => $_,
1943 }, grep { $_->{'overdue'} } @issues ],
1946 $_->{'timestamp'} = $_->{'newdate'};
1948 } @{ GetNewsToDisplay("slip",$branch) } ],
1952 return C4::Letters::GetPreparedLetter (
1953 module => 'circulation',
1954 letter_code => $letter_code,
1955 branchcode => $branch,
1957 'branches' => $branch,
1958 'borrowers' => $borrowernumber,
1964 =head2 GetBorrowersWithEmail
1966 ([$borrnum,$userid], ...) = GetBorrowersWithEmail('me@example.com');
1968 This gets a list of users and their basic details from their email address.
1969 As it's possible for multiple user to have the same email address, it provides
1970 you with all of them. If there is no userid for the user, there will be an
1971 C<undef> there. An empty list will be returned if there are no matches.
1975 sub GetBorrowersWithEmail {
1978 my $dbh = C4::Context->dbh;
1980 my $query = "SELECT borrowernumber, userid FROM borrowers WHERE email=?";
1981 my $sth=$dbh->prepare($query);
1982 $sth->execute($email);
1984 while (my $ref = $sth->fetch) {
1987 die "Failure searching for borrowers by email address: $sth->errstr" if $sth->err;
1991 =head2 AddMember_Opac
1995 sub AddMember_Opac {
1996 my ( %borrower ) = @_;
1998 $borrower{'categorycode'} //= C4::Context->preference('PatronSelfRegistrationDefaultCategory');
1999 if (not defined $borrower{'password'}){
2000 my $sr = new String::Random;
2001 $sr->{'A'} = [ 'A'..'Z', 'a'..'z' ];
2002 my $password = $sr->randpattern("AAAAAAAAAA");
2003 $borrower{'password'} = $password;
2006 $borrower{'cardnumber'} = fixup_cardnumber( $borrower{'cardnumber'} );
2008 my $borrowernumber = AddMember(%borrower);
2010 return ( $borrowernumber, $borrower{'password'} );
2013 =head2 AddEnrolmentFeeIfNeeded
2015 AddEnrolmentFeeIfNeeded( $borrower->{categorycode}, $borrower->{borrowernumber} );
2017 Add enrolment fee for a patron if needed.
2021 sub AddEnrolmentFeeIfNeeded {
2022 my ( $categorycode, $borrowernumber ) = @_;
2023 # check for enrollment fee & add it if needed
2024 my $dbh = C4::Context->dbh;
2025 my $sth = $dbh->prepare(q{
2028 WHERE categorycode=?
2030 $sth->execute( $categorycode );
2032 warn sprintf('Database returned the following error: %s', $sth->errstr);
2035 my ($enrolmentfee) = $sth->fetchrow;
2036 if ($enrolmentfee && $enrolmentfee > 0) {
2037 # insert fee in patron debts
2038 C4::Accounts::manualinvoice( $borrowernumber, '', '', 'A', $enrolmentfee );
2047 my ( $borrowernumber ) = @_;
2049 my $sql = "SELECT COUNT(*) FROM issues WHERE date_due < NOW() AND borrowernumber = ?";
2050 my $sth = C4::Context->dbh->prepare( $sql );
2051 $sth->execute( $borrowernumber );
2052 my ( $count ) = $sth->fetchrow_array();
2057 =head2 DeleteExpiredOpacRegistrations
2059 Delete accounts that haven't been upgraded from the 'temporary' category
2060 Returns the number of removed patrons
2064 sub DeleteExpiredOpacRegistrations {
2066 my $delay = C4::Context->preference('PatronSelfRegistrationExpireTemporaryAccountsDelay');
2067 my $category_code = C4::Context->preference('PatronSelfRegistrationDefaultCategory');
2069 return 0 if not $category_code or not defined $delay or $delay eq q||;
2072 SELECT borrowernumber
2074 WHERE categorycode = ? AND DATEDIFF( NOW(), dateenrolled ) > ? |;
2076 my $dbh = C4::Context->dbh;
2077 my $sth = $dbh->prepare($query);
2078 $sth->execute( $category_code, $delay );
2080 while ( my ($borrowernumber) = $sth->fetchrow_array() ) {
2081 DelMember($borrowernumber);
2087 =head2 DeleteUnverifiedOpacRegistrations
2089 Delete all unverified self registrations in borrower_modifications,
2090 older than the specified number of days.
2094 sub DeleteUnverifiedOpacRegistrations {
2096 my $dbh = C4::Context->dbh;
2098 DELETE FROM borrower_modifications
2099 WHERE borrowernumber = 0 AND DATEDIFF( NOW(), timestamp ) > ?|;
2100 my $cnt=$dbh->do($sql, undef, ($days) );
2101 return $cnt eq '0E0'? 0: $cnt;
2104 sub GetOverduesForPatron {
2105 my ( $borrowernumber ) = @_;
2109 FROM issues, items, biblio, biblioitems
2110 WHERE items.itemnumber=issues.itemnumber
2111 AND biblio.biblionumber = items.biblionumber
2112 AND biblio.biblionumber = biblioitems.biblionumber
2113 AND issues.borrowernumber = ?
2114 AND date_due < NOW()
2117 my $sth = C4::Context->dbh->prepare( $sql );
2118 $sth->execute( $borrowernumber );
2120 return $sth->fetchall_arrayref({});
2123 END { } # module clean-up code here (global destructor)