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 Koha::Patron::Debarments qw(IsDebarred);
41 use Text::Unaccent qw( unac_string );
42 use Koha::AuthUtils qw(hash_password);
45 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::Patron::Debarments::IsDebarred($borrowernumber);
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 @columns = C4::Member::columns();
557 Returns an array of borrowers' table columns on success,
558 and an empty array on failure.
564 # Pure ANSI SQL goodness.
565 my $sql = 'SELECT * FROM borrowers WHERE 1=0;';
567 # Get the database handle.
568 my $dbh = C4::Context->dbh;
570 # Run the SQL statement to load STH's readonly properties.
571 my $sth = $dbh->prepare($sql);
572 my $rv = $sth->execute();
574 # This only fails if the table doesn't exist.
575 # This will always be called AFTER an install or upgrade,
576 # so borrowers will exist!
578 if ($sth->{NUM_OF_FIELDS}>0) {
579 @data = @{$sth->{NAME}};
590 my $success = ModMember(borrowernumber => $borrowernumber,
591 [ field => value ]... );
593 Modify borrower's data. All date fields should ALREADY be in ISO format.
596 true on success, or false on failure
602 # test to know if you must update or not the borrower password
603 if (exists $data{password}) {
604 if ($data{password} eq '****' or $data{password} eq '') {
605 delete $data{password};
607 if ( C4::Context->preference('NorwegianPatronDBEnable') && C4::Context->preference('NorwegianPatronDBEnable') == 1 ) {
608 # Update the hashed PIN in borrower_sync.hashed_pin, before Koha hashes it
609 Koha::NorwegianPatronDB::NLUpdateHashedPIN( $data{'borrowernumber'}, $data{password} );
611 $data{password} = hash_password($data{password});
615 my $old_categorycode = GetBorrowerCategorycode( $data{borrowernumber} );
617 # get only the columns of a borrower
618 my $schema = Koha::Database->new()->schema;
619 my @columns = $schema->source('Borrower')->columns;
620 my $new_borrower = { map { join(' ', @columns) =~ /$_/ ? ( $_ => $data{$_} ) : () } keys(%data) };
621 delete $new_borrower->{flags};
623 $new_borrower->{dateofbirth} ||= undef if exists $new_borrower->{dateofbirth};
624 $new_borrower->{dateenrolled} ||= undef if exists $new_borrower->{dateenrolled};
625 $new_borrower->{dateexpiry} ||= undef if exists $new_borrower->{dateexpiry};
626 $new_borrower->{debarred} ||= undef if exists $new_borrower->{debarred};
627 $new_borrower->{sms_provider_id} ||= undef if exists $new_borrower->{sms_provider_id};
629 my $rs = $schema->resultset('Borrower')->search({
630 borrowernumber => $new_borrower->{borrowernumber},
633 delete $new_borrower->{userid} if exists $new_borrower->{userid} and not $new_borrower->{userid};
635 my $execute_success = $rs->update($new_borrower);
636 if ($execute_success ne '0E0') { # only proceed if the update was a success
637 # If the patron changes to a category with enrollment fee, we add a fee
638 if ( $data{categorycode} and $data{categorycode} ne $old_categorycode ) {
639 if ( C4::Context->preference('FeeOnChangePatronCategory') ) {
640 AddEnrolmentFeeIfNeeded( $data{categorycode}, $data{borrowernumber} );
644 # If NorwegianPatronDBEnable is enabled, we set syncstatus to something that a
645 # cronjob will use for syncing with NL
646 if ( C4::Context->preference('NorwegianPatronDBEnable') && C4::Context->preference('NorwegianPatronDBEnable') == 1 ) {
647 my $borrowersync = Koha::Database->new->schema->resultset('BorrowerSync')->find({
648 'synctype' => 'norwegianpatrondb',
649 'borrowernumber' => $data{'borrowernumber'}
651 # Do not set to "edited" if syncstatus is "new". We need to sync as new before
652 # we can sync as changed. And the "new sync" will pick up all changes since
653 # the patron was created anyway.
654 if ( $borrowersync->syncstatus ne 'new' && $borrowersync->syncstatus ne 'delete' ) {
655 $borrowersync->update( { 'syncstatus' => 'edited' } );
657 # Set the value of 'sync'
658 $borrowersync->update( { 'sync' => $data{'sync'} } );
659 # Try to do the live sync
660 Koha::NorwegianPatronDB::NLSync({ 'borrowernumber' => $data{'borrowernumber'} });
663 logaction("MEMBERS", "MODIFY", $data{'borrowernumber'}, "UPDATE (executed w/ arg: $data{'borrowernumber'})") if C4::Context->preference("BorrowersLog");
665 return $execute_success;
670 $borrowernumber = &AddMember(%borrower);
672 insert new borrower into table
674 (%borrower keys are database columns. Database columns could be
675 different in different versions. Please look into database for correct
678 Returns the borrowernumber upon success
680 Returns as undef upon any db error without further processing
687 my $dbh = C4::Context->dbh;
688 my $schema = Koha::Database->new()->schema;
690 # generate a proper login if none provided
691 $data{'userid'} = Generate_Userid( $data{'borrowernumber'}, $data{'firstname'}, $data{'surname'} )
692 if ( $data{'userid'} eq '' || !Check_Userid( $data{'userid'} ) );
694 # add expiration date if it isn't already there
695 unless ( $data{'dateexpiry'} ) {
696 $data{'dateexpiry'} = GetExpiryDate( $data{'categorycode'}, output_pref( { dt => dt_from_string, dateonly => 1, dateformat => 'iso' } ) );
699 # add enrollment date if it isn't already there
700 unless ( $data{'dateenrolled'} ) {
701 $data{'dateenrolled'} = output_pref( { dt => dt_from_string, dateonly => 1, dateformat => 'iso' } );
704 my $patron_category = $schema->resultset('Category')->find( $data{'categorycode'} );
706 $patron_category->default_privacy() eq 'default' ? 1
707 : $patron_category->default_privacy() eq 'never' ? 2
708 : $patron_category->default_privacy() eq 'forever' ? 0
711 $data{'privacy_guarantor_checkouts'} = 0 unless defined( $data{'privacy_guarantor_checkouts'} );
713 # Make a copy of the plain text password for later use
714 my $plain_text_password = $data{'password'};
716 # create a disabled account if no password provided
717 $data{'password'} = ($data{'password'})? hash_password($data{'password'}) : '!';
719 # we don't want invalid dates in the db (mysql has a bad habit of inserting 0000-00-00
720 $data{'dateofbirth'} = undef if ( not $data{'dateofbirth'} );
721 $data{'debarred'} = undef if ( not $data{'debarred'} );
722 $data{'sms_provider_id'} = undef if ( not $data{'sms_provider_id'} );
724 # get only the columns of Borrower
725 my @columns = $schema->source('Borrower')->columns;
726 my $new_member = { map { join(' ',@columns) =~ /$_/ ? ( $_ => $data{$_} ) : () } keys(%data) } ;
727 delete $new_member->{borrowernumber};
729 my $rs = $schema->resultset('Borrower');
730 $data{borrowernumber} = $rs->create($new_member)->id;
732 # If NorwegianPatronDBEnable is enabled, we set syncstatus to something that a
733 # cronjob will use for syncing with NL
734 if ( exists $data{'borrowernumber'} && C4::Context->preference('NorwegianPatronDBEnable') && C4::Context->preference('NorwegianPatronDBEnable') == 1 ) {
735 Koha::Database->new->schema->resultset('BorrowerSync')->create({
736 'borrowernumber' => $data{'borrowernumber'},
737 'synctype' => 'norwegianpatrondb',
739 'syncstatus' => 'new',
740 'hashed_pin' => Koha::NorwegianPatronDB::NLEncryptPIN( $plain_text_password ),
744 # mysql_insertid is probably bad. not necessarily accurate and mysql-specific at best.
745 logaction("MEMBERS", "CREATE", $data{'borrowernumber'}, "") if C4::Context->preference("BorrowersLog");
747 AddEnrolmentFeeIfNeeded( $data{categorycode}, $data{borrowernumber} );
749 return $data{borrowernumber};
754 my $uniqueness = Check_Userid($userid,$borrowernumber);
756 $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 != '').
758 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.
761 0 for not unique (i.e. this $userid already exists)
762 1 for unique (i.e. this $userid does not exist, or this $userid/$borrowernumber combination already exists)
767 my ( $uid, $borrowernumber ) = @_;
769 return 0 unless ($uid); # userid is a unique column, we should assume NULL is not unique
771 return 0 if ( $uid eq C4::Context->config('user') );
773 my $rs = Koha::Database->new()->schema()->resultset('Borrower');
776 $params->{userid} = $uid;
777 $params->{borrowernumber} = { '!=' => $borrowernumber } if ($borrowernumber);
779 my $count = $rs->count( $params );
781 return $count ? 0 : 1;
784 =head2 Generate_Userid
786 my $newuid = Generate_Userid($borrowernumber, $firstname, $surname);
788 Generate a userid using the $surname and the $firstname (if there is a value in $firstname).
790 $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.
793 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).
797 sub Generate_Userid {
798 my ($borrowernumber, $firstname, $surname) = @_;
801 #The script will "do" the following code and increment the $offset until Check_Userid = 1 (i.e. until $newuid comes back as unique)
803 $firstname =~ s/[[:digit:][:space:][:blank:][:punct:][:cntrl:]]//g;
804 $surname =~ s/[[:digit:][:space:][:blank:][:punct:][:cntrl:]]//g;
805 $newuid = lc(($firstname)? "$firstname.$surname" : $surname);
806 $newuid = unac_string('utf-8',$newuid);
807 $newuid .= $offset unless $offset == 0;
810 } while (!Check_Userid($newuid,$borrowernumber));
816 my ( $uid, $member, $digest ) = @_;
817 my $dbh = C4::Context->dbh;
819 #Make sure the userid chosen is unique and not theirs if non-empty. If it is not,
820 #Then we need to tell the user and have them create a new one.
824 "SELECT * FROM borrowers WHERE userid=? AND borrowernumber != ?");
825 $sth->execute( $uid, $member );
826 if ( ( $uid ne '' ) && ( my $row = $sth->fetchrow_hashref ) ) {
830 #Everything is good so we can update the information.
833 "update borrowers set userid=?, password=? where borrowernumber=?");
834 $sth->execute( $uid, $digest, $member );
838 logaction("MEMBERS", "CHANGE PASS", $member, "") if C4::Context->preference("BorrowersLog");
844 =head2 fixup_cardnumber
846 Warning: The caller is responsible for locking the members table in write
847 mode, to avoid database corruption.
851 use vars qw( @weightings );
852 my @weightings = ( 8, 4, 6, 3, 5, 2, 1 );
854 sub fixup_cardnumber {
855 my ($cardnumber) = @_;
856 my $autonumber_members = C4::Context->boolean_preference('autoMemberNum') || 0;
858 # Find out whether member numbers should be generated
859 # automatically. Should be either "1" or something else.
860 # Defaults to "0", which is interpreted as "no".
862 # if ($cardnumber !~ /\S/ && $autonumber_members) {
863 ($autonumber_members) or return $cardnumber;
864 my $checkdigit = C4::Context->preference('checkdigit');
865 my $dbh = C4::Context->dbh;
866 if ( $checkdigit and $checkdigit eq 'katipo' ) {
868 # if checkdigit is selected, calculate katipo-style cardnumber.
869 # otherwise, just use the max()
870 # purpose: generate checksum'd member numbers.
871 # We'll assume we just got the max value of digits 2-8 of member #'s
872 # from the database and our job is to increment that by one,
873 # determine the 1st and 9th digits and return the full string.
874 my $sth = $dbh->prepare(
875 "select max(substring(borrowers.cardnumber,2,7)) as new_num from borrowers"
878 my $data = $sth->fetchrow_hashref;
879 $cardnumber = $data->{new_num};
880 if ( !$cardnumber ) { # If DB has no values,
881 $cardnumber = 1000000; # start at 1000000
887 for ( my $i = 0 ; $i < 8 ; $i += 1 ) {
888 # read weightings, left to right, 1 char at a time
889 my $temp1 = $weightings[$i];
891 # sequence left to right, 1 char at a time
892 my $temp2 = substr( $cardnumber, $i, 1 );
894 # mult each char 1-7 by its corresponding weighting
895 $sum += $temp1 * $temp2;
898 my $rem = ( $sum % 11 );
899 $rem = 'X' if $rem == 10;
901 return "V$cardnumber$rem";
904 my $sth = $dbh->prepare(
905 'SELECT MAX( CAST( cardnumber AS SIGNED ) ) FROM borrowers WHERE cardnumber REGEXP "^-?[0-9]+$"'
908 my ($result) = $sth->fetchrow;
911 return $cardnumber; # just here as a fallback/reminder
914 =head2 GetPendingIssues
916 my $issues = &GetPendingIssues(@borrowernumber);
918 Looks up what the patron with the given borrowernumber has borrowed.
920 C<&GetPendingIssues> returns a
921 reference-to-array where each element is a reference-to-hash; the
922 keys are the fields from the C<issues>, C<biblio>, and C<items> tables.
923 The keys include C<biblioitems> fields except marc and marcxml.
927 sub GetPendingIssues {
928 my @borrowernumbers = @_;
930 unless (@borrowernumbers ) { # return a ref_to_array
931 return \@borrowernumbers; # to not cause surprise to caller
934 # Borrowers part of the query
936 for (my $i = 0; $i < @borrowernumbers; $i++) {
937 $bquery .= ' issues.borrowernumber = ?';
938 if ($i < $#borrowernumbers ) {
943 # must avoid biblioitems.* to prevent large marc and marcxml fields from killing performance
944 # FIXME: namespace collision: each table has "timestamp" fields. Which one is "timestamp" ?
945 # FIXME: circ/ciculation.pl tries to sort by timestamp!
946 # FIXME: namespace collision: other collisions possible.
947 # FIXME: most of this data isn't really being used by callers.
954 biblioitems.itemtype,
957 biblioitems.publicationyear,
958 biblioitems.publishercode,
959 biblioitems.volumedate,
960 biblioitems.volumedesc,
965 borrowers.cardnumber,
966 issues.timestamp AS timestamp,
967 issues.renewals AS renewals,
968 issues.borrowernumber AS borrowernumber,
969 items.renewals AS totalrenewals
971 LEFT JOIN items ON items.itemnumber = issues.itemnumber
972 LEFT JOIN biblio ON items.biblionumber = biblio.biblionumber
973 LEFT JOIN biblioitems ON items.biblioitemnumber = biblioitems.biblioitemnumber
974 LEFT JOIN borrowers ON issues.borrowernumber = borrowers.borrowernumber
977 ORDER BY issues.issuedate"
980 my $sth = C4::Context->dbh->prepare($query);
981 $sth->execute(@borrowernumbers);
982 my $data = $sth->fetchall_arrayref({});
983 my $today = dt_from_string;
985 if ($_->{issuedate}) {
986 $_->{issuedate} = dt_from_string($_->{issuedate}, 'sql');
988 $_->{date_due_sql} = $_->{date_due};
989 # FIXME no need to have this value
990 $_->{date_due} or next;
991 $_->{date_due_sql} = $_->{date_due};
992 # FIXME no need to have this value
993 $_->{date_due} = dt_from_string($_->{date_due}, 'sql');
994 if ( DateTime->compare($_->{date_due}, $today) == -1 ) {
1003 $issues = &GetAllIssues($borrowernumber, $sortkey, $limit);
1005 Looks up what the patron with the given borrowernumber has borrowed,
1006 and sorts the results.
1008 C<$sortkey> is the name of a field on which to sort the results. This
1009 should be the name of a field in the C<issues>, C<biblio>,
1010 C<biblioitems>, or C<items> table in the Koha database.
1012 C<$limit> is the maximum number of results to return.
1014 C<&GetAllIssues> an arrayref, C<$issues>, of hashrefs, the keys of which
1015 are the fields from the C<issues>, C<biblio>, C<biblioitems>, and
1016 C<items> tables of the Koha database.
1022 my ( $borrowernumber, $order, $limit ) = @_;
1024 return unless $borrowernumber;
1025 $order = 'date_due desc' unless $order;
1027 my $dbh = C4::Context->dbh;
1029 'SELECT *, issues.timestamp as issuestimestamp, issues.renewals AS renewals,items.renewals AS totalrenewals,items.timestamp AS itemstimestamp
1031 LEFT JOIN items on items.itemnumber=issues.itemnumber
1032 LEFT JOIN biblio ON items.biblionumber=biblio.biblionumber
1033 LEFT JOIN biblioitems ON items.biblioitemnumber=biblioitems.biblioitemnumber
1034 WHERE borrowernumber=?
1036 SELECT *, old_issues.timestamp as issuestimestamp, old_issues.renewals AS renewals,items.renewals AS totalrenewals,items.timestamp AS itemstimestamp
1038 LEFT JOIN items on items.itemnumber=old_issues.itemnumber
1039 LEFT JOIN biblio ON items.biblionumber=biblio.biblionumber
1040 LEFT JOIN biblioitems ON items.biblioitemnumber=biblioitems.biblioitemnumber
1041 WHERE borrowernumber=? AND old_issues.itemnumber IS NOT NULL
1042 order by ' . $order;
1044 $query .= " limit $limit";
1047 my $sth = $dbh->prepare($query);
1048 $sth->execute( $borrowernumber, $borrowernumber );
1049 return $sth->fetchall_arrayref( {} );
1053 =head2 GetMemberAccountRecords
1055 ($total, $acctlines, $count) = &GetMemberAccountRecords($borrowernumber);
1057 Looks up accounting data for the patron with the given borrowernumber.
1059 C<&GetMemberAccountRecords> returns a three-element array. C<$acctlines> is a
1060 reference-to-array, where each element is a reference-to-hash; the
1061 keys are the fields of the C<accountlines> table in the Koha database.
1062 C<$count> is the number of elements in C<$acctlines>. C<$total> is the
1063 total amount outstanding for all of the account lines.
1067 sub GetMemberAccountRecords {
1068 my ($borrowernumber) = @_;
1069 my $dbh = C4::Context->dbh;
1075 WHERE borrowernumber=?);
1076 $strsth.=" ORDER BY accountlines_id desc";
1077 my $sth= $dbh->prepare( $strsth );
1078 $sth->execute( $borrowernumber );
1081 while ( my $data = $sth->fetchrow_hashref ) {
1082 if ( $data->{itemnumber} ) {
1083 my $biblio = GetBiblioFromItemNumber( $data->{itemnumber} );
1084 $data->{biblionumber} = $biblio->{biblionumber};
1085 $data->{title} = $biblio->{title};
1087 $acctlines[$numlines] = $data;
1089 $total += sprintf "%.0f", 1000*$data->{amountoutstanding}; # convert float to integer to avoid round-off errors
1092 return ( $total, \@acctlines,$numlines);
1095 =head2 GetMemberAccountBalance
1097 ($total_balance, $non_issue_balance, $other_charges) = &GetMemberAccountBalance($borrowernumber);
1099 Calculates amount immediately owing by the patron - non-issue charges.
1100 Based on GetMemberAccountRecords.
1101 Charges exempt from non-issue are:
1103 * Rent (rental) if RentalsInNoissuesCharge syspref is set to false
1104 * Manual invoices if ManInvInNoissuesCharge syspref is set to false
1108 sub GetMemberAccountBalance {
1109 my ($borrowernumber) = @_;
1111 my $ACCOUNT_TYPE_LENGTH = 5; # this is plain ridiculous...
1114 push @not_fines, 'Res' unless C4::Context->preference('HoldsInNoissuesCharge');
1115 push @not_fines, 'Rent' unless C4::Context->preference('RentalsInNoissuesCharge');
1116 unless ( C4::Context->preference('ManInvInNoissuesCharge') ) {
1117 my $dbh = C4::Context->dbh;
1118 my $man_inv_types = $dbh->selectcol_arrayref(qq{SELECT authorised_value FROM authorised_values WHERE category = 'MANUAL_INV'});
1119 push @not_fines, map substr($_, 0, $ACCOUNT_TYPE_LENGTH), @$man_inv_types;
1121 my %not_fine = map {$_ => 1} @not_fines;
1123 my ($total, $acctlines) = GetMemberAccountRecords($borrowernumber);
1124 my $other_charges = 0;
1125 foreach (@$acctlines) {
1126 $other_charges += $_->{amountoutstanding} if $not_fine{ substr($_->{accounttype}, 0, $ACCOUNT_TYPE_LENGTH) };
1129 return ( $total, $total - $other_charges, $other_charges);
1132 =head2 GetBorNotifyAcctRecord
1134 ($total, $acctlines, $count) = &GetBorNotifyAcctRecord($params,$notifyid);
1136 Looks up accounting data for the patron with the given borrowernumber per file number.
1138 C<&GetBorNotifyAcctRecord> returns a three-element array. C<$acctlines> is a
1139 reference-to-array, where each element is a reference-to-hash; the
1140 keys are the fields of the C<accountlines> table in the Koha database.
1141 C<$count> is the number of elements in C<$acctlines>. C<$total> is the
1142 total amount outstanding for all of the account lines.
1146 sub GetBorNotifyAcctRecord {
1147 my ( $borrowernumber, $notifyid ) = @_;
1148 my $dbh = C4::Context->dbh;
1151 my $sth = $dbh->prepare(
1154 WHERE borrowernumber=?
1156 AND amountoutstanding != '0'
1157 ORDER BY notify_id,accounttype
1160 $sth->execute( $borrowernumber, $notifyid );
1162 while ( my $data = $sth->fetchrow_hashref ) {
1163 if ( $data->{itemnumber} ) {
1164 my $biblio = GetBiblioFromItemNumber( $data->{itemnumber} );
1165 $data->{biblionumber} = $biblio->{biblionumber};
1166 $data->{title} = $biblio->{title};
1168 $acctlines[$numlines] = $data;
1170 $total += int(100 * $data->{'amountoutstanding'});
1173 return ( $total, \@acctlines, $numlines );
1176 =head2 checkuniquemember (OUEST-PROVENCE)
1178 ($result,$categorycode) = &checkuniquemember($collectivity,$surname,$firstname,$dateofbirth);
1180 Checks that a member exists or not in the database.
1182 C<&result> is nonzero (=exist) or 0 (=does not exist)
1183 C<&categorycode> is from categorycode table
1184 C<&collectivity> is 1 (= we add a collectivity) or 0 (= we add a physical member)
1185 C<&surname> is the surname
1186 C<&firstname> is the firstname (only if collectivity=0)
1187 C<&dateofbirth> is the date of birth in ISO format (only if collectivity=0)
1191 # FIXME: This function is not legitimate. Multiple patrons might have the same first/last name and birthdate.
1192 # This is especially true since first name is not even a required field.
1194 sub checkuniquemember {
1195 my ( $collectivity, $surname, $firstname, $dateofbirth ) = @_;
1196 my $dbh = C4::Context->dbh;
1197 my $request = ($collectivity) ?
1198 "SELECT borrowernumber,categorycode FROM borrowers WHERE surname=? " :
1200 "SELECT borrowernumber,categorycode FROM borrowers WHERE surname=? and firstname=? and dateofbirth=?" :
1201 "SELECT borrowernumber,categorycode FROM borrowers WHERE surname=? and firstname=?";
1202 my $sth = $dbh->prepare($request);
1203 if ($collectivity) {
1204 $sth->execute( uc($surname) );
1205 } elsif($dateofbirth){
1206 $sth->execute( uc($surname), ucfirst($firstname), $dateofbirth );
1208 $sth->execute( uc($surname), ucfirst($firstname));
1210 my @data = $sth->fetchrow;
1211 ( $data[0] ) and return $data[0], $data[1];
1215 sub checkcardnumber {
1216 my ( $cardnumber, $borrowernumber ) = @_;
1218 # If cardnumber is null, we assume they're allowed.
1219 return 0 unless defined $cardnumber;
1221 my $dbh = C4::Context->dbh;
1222 my $query = "SELECT * FROM borrowers WHERE cardnumber=?";
1223 $query .= " AND borrowernumber <> ?" if ($borrowernumber);
1224 my $sth = $dbh->prepare($query);
1227 ( $borrowernumber ? $borrowernumber : () )
1230 return 1 if $sth->fetchrow_hashref;
1232 my ( $min_length, $max_length ) = get_cardnumber_length();
1234 if length $cardnumber > $max_length
1235 or length $cardnumber < $min_length;
1240 =head2 get_cardnumber_length
1242 my ($min, $max) = C4::Members::get_cardnumber_length()
1244 Returns the minimum and maximum length for patron cardnumbers as
1245 determined by the CardnumberLength system preference, the
1246 BorrowerMandatoryField system preference, and the width of the
1251 sub get_cardnumber_length {
1252 my ( $min, $max ) = ( 0, 16 ); # borrowers.cardnumber is a nullable varchar(16)
1253 $min = 1 if C4::Context->preference('BorrowerMandatoryField') =~ /cardnumber/;
1254 if ( my $cardnumber_length = C4::Context->preference('CardnumberLength') ) {
1255 # Is integer and length match
1256 if ( $cardnumber_length =~ m|^\d+$| ) {
1257 $min = $max = $cardnumber_length
1258 if $cardnumber_length >= $min
1259 and $cardnumber_length <= $max;
1261 # Else assuming it is a range
1262 elsif ( $cardnumber_length =~ m|(\d*),(\d*)| ) {
1263 $min = $1 if $1 and $min < $1;
1264 $max = $2 if $2 and $max > $2;
1268 return ( $min, $max );
1271 =head2 GetFirstValidEmailAddress
1273 $email = GetFirstValidEmailAddress($borrowernumber);
1275 Return the first valid email address for a borrower, given the borrowernumber. For now, the order
1276 is defined as email, emailpro, B_email. Returns the empty string if the borrower has no email
1281 sub GetFirstValidEmailAddress {
1282 my $borrowernumber = shift;
1283 my $dbh = C4::Context->dbh;
1284 my $sth = $dbh->prepare( "SELECT email, emailpro, B_email FROM borrowers where borrowernumber = ? ");
1285 $sth->execute( $borrowernumber );
1286 my $data = $sth->fetchrow_hashref;
1288 if ($data->{'email'}) {
1289 return $data->{'email'};
1290 } elsif ($data->{'emailpro'}) {
1291 return $data->{'emailpro'};
1292 } elsif ($data->{'B_email'}) {
1293 return $data->{'B_email'};
1299 =head2 GetNoticeEmailAddress
1301 $email = GetNoticeEmailAddress($borrowernumber);
1303 Return the email address of borrower used for notices, given the borrowernumber.
1304 Returns the empty string if no email address.
1308 sub GetNoticeEmailAddress {
1309 my $borrowernumber = shift;
1311 my $which_address = C4::Context->preference("AutoEmailPrimaryAddress");
1312 # if syspref is set to 'first valid' (value == OFF), look up email address
1313 if ( $which_address eq 'OFF' ) {
1314 return GetFirstValidEmailAddress($borrowernumber);
1316 # specified email address field
1317 my $dbh = C4::Context->dbh;
1318 my $sth = $dbh->prepare( qq{
1319 SELECT $which_address AS primaryemail
1321 WHERE borrowernumber=?
1323 $sth->execute($borrowernumber);
1324 my $data = $sth->fetchrow_hashref;
1325 return $data->{'primaryemail'} || '';
1328 =head2 GetExpiryDate
1330 $expirydate = GetExpiryDate($categorycode, $dateenrolled);
1332 Calculate expiry date given a categorycode and starting date. Date argument must be in ISO format.
1333 Return date is also in ISO format.
1338 my ( $categorycode, $dateenrolled ) = @_;
1340 if ($categorycode) {
1341 my $dbh = C4::Context->dbh;
1342 my $sth = $dbh->prepare("SELECT enrolmentperiod,enrolmentperioddate FROM categories WHERE categorycode=?");
1343 $sth->execute($categorycode);
1344 $enrolments = $sth->fetchrow_hashref;
1346 # die "GetExpiryDate: for enrollmentperiod $enrolmentperiod (category '$categorycode') starting $dateenrolled.\n";
1347 my @date = split (/-/,$dateenrolled);
1348 if($enrolments->{enrolmentperiod}){
1349 return sprintf("%04d-%02d-%02d", Add_Delta_YM(@date,0,$enrolments->{enrolmentperiod}));
1351 return $enrolments->{enrolmentperioddate};
1355 =head2 GetUpcomingMembershipExpires
1357 my $expires = GetUpcomingMembershipExpires({
1358 branch => $branch, before => $before, after => $after,
1361 $branch is an optional branch code.
1362 $before/$after is an optional number of days before/after the date that
1363 is set by the preference MembershipExpiryDaysNotice.
1364 If the pref would be 14, before 2 and after 3, you will get all expires
1369 sub GetUpcomingMembershipExpires {
1370 my ( $params ) = @_;
1371 my $before = $params->{before} || 0;
1372 my $after = $params->{after} || 0;
1373 my $branch = $params->{branch};
1375 my $dbh = C4::Context->dbh;
1376 my $days = C4::Context->preference("MembershipExpiryDaysNotice") || 0;
1377 my $date1 = dt_from_string->add( days => $days - $before );
1378 my $date2 = dt_from_string->add( days => $days + $after );
1379 $date1= output_pref({ dt => $date1, dateformat => 'iso', dateonly => 1 });
1380 $date2= output_pref({ dt => $date2, dateformat => 'iso', dateonly => 1 });
1383 SELECT borrowers.*, categories.description,
1384 branches.branchname, branches.branchemail FROM borrowers
1385 LEFT JOIN branches USING (branchcode)
1386 LEFT JOIN categories USING (categorycode)
1389 $query.= 'WHERE branchcode=? AND dateexpiry BETWEEN ? AND ?';
1391 $query.= 'WHERE dateexpiry BETWEEN ? AND ?';
1394 my $sth = $dbh->prepare( $query );
1395 my @pars = $branch? ( $branch ): ();
1396 push @pars, $date1, $date2;
1397 $sth->execute( @pars );
1398 my $results = $sth->fetchall_arrayref( {} );
1402 =head2 GetborCatFromCatType
1404 ($codes_arrayref, $labels_hashref) = &GetborCatFromCatType();
1406 Looks up the different types of borrowers in the database. Returns two
1407 elements: a reference-to-array, which lists the borrower category
1408 codes, and a reference-to-hash, which maps the borrower category codes
1409 to category descriptions.
1414 sub GetborCatFromCatType {
1415 my ( $category_type, $action, $no_branch_limit ) = @_;
1417 my $branch_limit = $no_branch_limit
1419 : C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1421 # FIXME - This API seems both limited and dangerous.
1422 my $dbh = C4::Context->dbh;
1425 SELECT DISTINCT categories.categorycode, categories.description
1429 LEFT JOIN categories_branches ON categories.categorycode = categories_branches.categorycode
1432 $request .= " $action ";
1433 $request .= " AND (branchcode = ? OR branchcode IS NULL)" if $branch_limit;
1435 $request .= " WHERE branchcode = ? OR branchcode IS NULL" if $branch_limit;
1437 $request .= " ORDER BY categorycode";
1439 my $sth = $dbh->prepare($request);
1441 $action ? $category_type : (),
1442 $branch_limit ? $branch_limit : ()
1448 while ( my $data = $sth->fetchrow_hashref ) {
1449 push @codes, $data->{'categorycode'};
1450 $labels{ $data->{'categorycode'} } = $data->{'description'};
1453 return ( \@codes, \%labels );
1456 =head2 GetBorrowercategory
1458 $hashref = &GetBorrowercategory($categorycode);
1460 Given the borrower's category code, the function returns the corresponding
1461 data hashref for a comprehensive information display.
1465 sub GetBorrowercategory {
1467 my $dbh = C4::Context->dbh;
1471 "SELECT description,dateofbirthrequired,upperagelimit,category_type
1473 WHERE categorycode = ?"
1475 $sth->execute($catcode);
1477 $sth->fetchrow_hashref;
1481 } # sub getborrowercategory
1484 =head2 GetBorrowerCategorycode
1486 $categorycode = &GetBorrowerCategoryCode( $borrowernumber );
1488 Given the borrowernumber, the function returns the corresponding categorycode
1492 sub GetBorrowerCategorycode {
1493 my ( $borrowernumber ) = @_;
1494 my $dbh = C4::Context->dbh;
1495 my $sth = $dbh->prepare( qq{
1498 WHERE borrowernumber = ?
1500 $sth->execute( $borrowernumber );
1501 return $sth->fetchrow;
1504 =head2 GetBorrowercategoryList
1506 $arrayref_hashref = &GetBorrowercategoryList;
1507 If no category code provided, the function returns all the categories.
1511 sub GetBorrowercategoryList {
1512 my $no_branch_limit = @_ ? shift : 0;
1513 my $branch_limit = $no_branch_limit
1515 : C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1516 my $dbh = C4::Context->dbh;
1517 my $query = "SELECT categories.* FROM categories";
1519 LEFT JOIN categories_branches ON categories.categorycode = categories_branches.categorycode
1520 WHERE branchcode = ? OR branchcode IS NULL GROUP BY description
1522 $query .= " ORDER BY description";
1523 my $sth = $dbh->prepare( $query );
1524 $sth->execute( $branch_limit ? $branch_limit : () );
1525 my $data = $sth->fetchall_arrayref( {} );
1528 } # sub getborrowercategory
1532 $dateofbirth,$date = &GetAge($date);
1534 this function return the borrowers age with the value of dateofbirth
1540 my ( $date, $date_ref ) = @_;
1542 if ( not defined $date_ref ) {
1543 $date_ref = sprintf( '%04d-%02d-%02d', Today() );
1546 my ( $year1, $month1, $day1 ) = split /-/, $date;
1547 my ( $year2, $month2, $day2 ) = split /-/, $date_ref;
1549 my $age = $year2 - $year1;
1550 if ( $month1 . $day1 > $month2 . $day2 ) {
1559 $borrower = C4::Members::SetAge($borrower, $datetimeduration);
1560 $borrower = C4::Members::SetAge($borrower, '0015-12-10');
1561 $borrower = C4::Members::SetAge($borrower, $datetimeduration, $datetime_reference);
1563 eval { $borrower = C4::Members::SetAge($borrower, '015-1-10'); };
1564 if ($@) {print $@;} #Catch a bad ISO Date or kill your script!
1566 This function sets the borrower's dateofbirth to match the given age.
1567 Optionally relative to the given $datetime_reference.
1569 @PARAM1 koha.borrowers-object
1570 @PARAM2 DateTime::Duration-object as the desired age
1571 OR a ISO 8601 Date. (To make the API more pleasant)
1572 @PARAM3 DateTime-object as the relative date, defaults to now().
1573 RETURNS The given borrower reference @PARAM1.
1574 DIES If there was an error with the ISO Date handling.
1580 my ( $borrower, $datetimeduration, $datetime_ref ) = @_;
1581 $datetime_ref = DateTime->now() unless $datetime_ref;
1583 if ($datetimeduration && ref $datetimeduration ne 'DateTime::Duration') {
1584 if ($datetimeduration =~ /^(\d{4})-(\d{2})-(\d{2})/) {
1585 $datetimeduration = DateTime::Duration->new(years => $1, months => $2, days => $3);
1588 die "C4::Members::SetAge($borrower, $datetimeduration), datetimeduration not a valid ISO 8601 Date!\n";
1592 my $new_datetime_ref = $datetime_ref->clone();
1593 $new_datetime_ref->subtract_duration( $datetimeduration );
1595 $borrower->{dateofbirth} = $new_datetime_ref->ymd();
1600 =head2 GetSortDetails (OUEST-PROVENCE)
1602 ($lib) = &GetSortDetails($category,$sortvalue);
1604 Returns the authorized value details
1605 C<&$lib>return value of authorized value details
1606 C<&$sortvalue>this is the value of authorized value
1607 C<&$category>this is the value of authorized value category
1611 sub GetSortDetails {
1612 my ( $category, $sortvalue ) = @_;
1613 my $dbh = C4::Context->dbh;
1614 my $query = qq|SELECT lib
1615 FROM authorised_values
1617 AND authorised_value=? |;
1618 my $sth = $dbh->prepare($query);
1619 $sth->execute( $category, $sortvalue );
1620 my $lib = $sth->fetchrow;
1621 return ($lib) if ($lib);
1622 return ($sortvalue) unless ($lib);
1625 =head2 MoveMemberToDeleted
1627 $result = &MoveMemberToDeleted($borrowernumber);
1629 Copy the record from borrowers to deletedborrowers table.
1630 The routine returns 1 for success, undef for failure.
1634 sub MoveMemberToDeleted {
1635 my ($member) = shift or return;
1637 my $schema = Koha::Database->new()->schema();
1638 my $borrowers_rs = $schema->resultset('Borrower');
1639 $borrowers_rs->result_class('DBIx::Class::ResultClass::HashRefInflator');
1640 my $borrower = $borrowers_rs->find($member);
1641 return unless $borrower;
1643 my $deleted = $schema->resultset('Deletedborrower')->create($borrower);
1645 return $deleted ? 1 : undef;
1650 DelMember($borrowernumber);
1652 This function remove directly a borrower whitout writing it on deleteborrower.
1653 + Deletes reserves for the borrower
1658 my $dbh = C4::Context->dbh;
1659 my $borrowernumber = shift;
1660 #warn "in delmember with $borrowernumber";
1661 return unless $borrowernumber; # borrowernumber is mandatory.
1662 # Delete Patron's holds
1663 my @holds = Koha::Holds->search({ borrowernumber => $borrowernumber });
1664 $_->delete for @holds;
1669 WHERE borrowernumber = ?
1671 my $sth = $dbh->prepare($query);
1672 $sth->execute($borrowernumber);
1673 logaction("MEMBERS", "DELETE", $borrowernumber, "") if C4::Context->preference("BorrowersLog");
1677 =head2 HandleDelBorrower
1679 HandleDelBorrower($borrower);
1681 When a member is deleted (DelMember in Members.pm), you should call me first.
1682 This routine deletes/moves lists and entries for the deleted member/borrower.
1683 Lists owned by the borrower are deleted, but entries from the borrower to
1684 other lists are kept.
1688 sub HandleDelBorrower {
1691 my $dbh = C4::Context->dbh;
1693 #Delete all lists and all shares of this borrower
1694 #Consistent with the approach Koha uses on deleting individual lists
1695 #Note that entries in virtualshelfcontents added by this borrower to
1696 #lists of others will be handled by a table constraint: the borrower
1697 #is set to NULL in those entries.
1698 $query="DELETE FROM virtualshelves WHERE owner=?";
1699 $dbh->do($query,undef,($borrower));
1702 #We could handle the above deletes via a constraint too.
1703 #But a new BZ report 11889 has been opened to discuss another approach.
1704 #Instead of deleting we could also disown lists (based on a pref).
1705 #In that way we could save shared and public lists.
1706 #The current table constraints support that idea now.
1707 #This pref should then govern the results of other routines/methods such as
1708 #Koha::Virtualshelf->new->delete too.
1711 =head2 ExtendMemberSubscriptionTo (OUEST-PROVENCE)
1713 $date = ExtendMemberSubscriptionTo($borrowerid, $date);
1715 Extending the subscription to a given date or to the expiry date calculated on ISO date.
1720 sub ExtendMemberSubscriptionTo {
1721 my ( $borrowerid,$date) = @_;
1722 my $dbh = C4::Context->dbh;
1723 my $borrower = GetMember('borrowernumber'=>$borrowerid);
1725 $date = (C4::Context->preference('BorrowerRenewalPeriodBase') eq 'dateexpiry') ?
1726 eval { output_pref( { dt => dt_from_string( $borrower->{'dateexpiry'} ), dateonly => 1, dateformat => 'iso' } ); }
1728 output_pref( { dt => dt_from_string, dateonly => 1, dateformat => 'iso' } );
1729 $date = GetExpiryDate( $borrower->{'categorycode'}, $date );
1731 my $sth = $dbh->do(<<EOF);
1733 SET dateexpiry='$date'
1734 WHERE borrowernumber='$borrowerid'
1737 AddEnrolmentFeeIfNeeded( $borrower->{categorycode}, $borrower->{borrowernumber} );
1739 logaction("MEMBERS", "RENEW", $borrower->{'borrowernumber'}, "Membership renewed")if C4::Context->preference("BorrowersLog");
1740 return $date if ($sth);
1744 =head2 GetHideLostItemsPreference
1746 $hidelostitemspref = &GetHideLostItemsPreference($borrowernumber);
1748 Returns the HideLostItems preference for the patron category of the supplied borrowernumber
1749 C<&$hidelostitemspref>return value of function, 0 or 1
1753 sub GetHideLostItemsPreference {
1754 my ($borrowernumber) = @_;
1755 my $dbh = C4::Context->dbh;
1756 my $query = "SELECT hidelostitems FROM borrowers,categories WHERE borrowers.categorycode = categories.categorycode AND borrowernumber = ?";
1757 my $sth = $dbh->prepare($query);
1758 $sth->execute($borrowernumber);
1759 my $hidelostitems = $sth->fetchrow;
1760 return $hidelostitems;
1763 =head2 GetBorrowersToExpunge
1765 $borrowers = &GetBorrowersToExpunge(
1766 not_borrowed_since => $not_borrowed_since,
1767 expired_before => $expired_before,
1768 category_code => $category_code,
1769 patron_list_id => $patron_list_id,
1770 branchcode => $branchcode
1773 This function get all borrowers based on the given criteria.
1777 sub GetBorrowersToExpunge {
1780 my $filterdate = $params->{'not_borrowed_since'};
1781 my $filterexpiry = $params->{'expired_before'};
1782 my $filtercategory = $params->{'category_code'};
1783 my $filterbranch = $params->{'branchcode'} ||
1784 ((C4::Context->preference('IndependentBranches')
1785 && C4::Context->userenv
1786 && !C4::Context->IsSuperLibrarian()
1787 && C4::Context->userenv->{branch})
1788 ? C4::Context->userenv->{branch}
1790 my $filterpatronlist = $params->{'patron_list_id'};
1792 my $dbh = C4::Context->dbh;
1794 SELECT borrowers.borrowernumber,
1795 MAX(old_issues.timestamp) AS latestissue,
1796 MAX(issues.timestamp) AS currentissue
1798 JOIN categories USING (categorycode)
1802 WHERE guarantorid IS NOT NULL
1803 AND guarantorid <> 0
1804 ) as tmp ON borrowers.borrowernumber=tmp.guarantorid
1805 LEFT JOIN old_issues USING (borrowernumber)
1806 LEFT JOIN issues USING (borrowernumber)|;
1807 if ( $filterpatronlist ){
1808 $query .= q| LEFT JOIN patron_list_patrons USING (borrowernumber)|;
1810 $query .= q| WHERE category_type <> 'S'
1811 AND tmp.guarantorid IS NULL
1814 if ( $filterbranch && $filterbranch ne "" ) {
1815 $query.= " AND borrowers.branchcode = ? ";
1816 push( @query_params, $filterbranch );
1818 if ( $filterexpiry ) {
1819 $query .= " AND dateexpiry < ? ";
1820 push( @query_params, $filterexpiry );
1822 if ( $filtercategory ) {
1823 $query .= " AND categorycode = ? ";
1824 push( @query_params, $filtercategory );
1826 if ( $filterpatronlist ){
1827 $query.=" AND patron_list_id = ? ";
1828 push( @query_params, $filterpatronlist );
1830 $query.=" GROUP BY borrowers.borrowernumber HAVING currentissue IS NULL ";
1831 if ( $filterdate ) {
1832 $query.=" AND ( latestissue < ? OR latestissue IS NULL ) ";
1833 push @query_params,$filterdate;
1835 warn $query if $debug;
1837 my $sth = $dbh->prepare($query);
1838 if (scalar(@query_params)>0){
1839 $sth->execute(@query_params);
1846 while ( my $data = $sth->fetchrow_hashref ) {
1847 push @results, $data;
1852 =head2 GetBorrowersWhoHaveNeverBorrowed
1854 $results = &GetBorrowersWhoHaveNeverBorrowed
1856 This function get all borrowers who have never borrowed.
1858 I<$result> is a ref to an array which all elements are a hasref.
1862 sub GetBorrowersWhoHaveNeverBorrowed {
1863 my $filterbranch = shift ||
1864 ((C4::Context->preference('IndependentBranches')
1865 && C4::Context->userenv
1866 && !C4::Context->IsSuperLibrarian()
1867 && C4::Context->userenv->{branch})
1868 ? C4::Context->userenv->{branch}
1870 my $dbh = C4::Context->dbh;
1872 SELECT borrowers.borrowernumber,max(timestamp) as latestissue
1874 LEFT JOIN issues ON borrowers.borrowernumber = issues.borrowernumber
1875 WHERE issues.borrowernumber IS NULL
1878 if ($filterbranch && $filterbranch ne ""){
1879 $query.=" AND borrowers.branchcode= ?";
1880 push @query_params,$filterbranch;
1882 warn $query if $debug;
1884 my $sth = $dbh->prepare($query);
1885 if (scalar(@query_params)>0){
1886 $sth->execute(@query_params);
1893 while ( my $data = $sth->fetchrow_hashref ) {
1894 push @results, $data;
1899 =head2 GetBorrowersWithIssuesHistoryOlderThan
1901 $results = &GetBorrowersWithIssuesHistoryOlderThan($date)
1903 this function get all borrowers who has an issue history older than I<$date> given on input arg.
1905 I<$result> is a ref to an array which all elements are a hashref.
1906 This hashref is containt the number of time this borrowers has borrowed before I<$date> and the borrowernumber.
1910 sub GetBorrowersWithIssuesHistoryOlderThan {
1911 my $dbh = C4::Context->dbh;
1912 my $date = shift ||POSIX::strftime("%Y-%m-%d",localtime());
1913 my $filterbranch = shift ||
1914 ((C4::Context->preference('IndependentBranches')
1915 && C4::Context->userenv
1916 && !C4::Context->IsSuperLibrarian()
1917 && C4::Context->userenv->{branch})
1918 ? C4::Context->userenv->{branch}
1921 SELECT count(borrowernumber) as n,borrowernumber
1923 WHERE returndate < ?
1924 AND borrowernumber IS NOT NULL
1927 push @query_params, $date;
1929 $query.=" AND branchcode = ?";
1930 push @query_params, $filterbranch;
1932 $query.=" GROUP BY borrowernumber ";
1933 warn $query if $debug;
1934 my $sth = $dbh->prepare($query);
1935 $sth->execute(@query_params);
1938 while ( my $data = $sth->fetchrow_hashref ) {
1939 push @results, $data;
1944 =head2 GetBorrowersNamesAndLatestIssue
1946 $results = &GetBorrowersNamesAndLatestIssueList(@borrowernumbers)
1948 this function get borrowers Names and surnames and Issue information.
1950 I<@borrowernumbers> is an array which all elements are borrowernumbers.
1951 This hashref is containt the number of time this borrowers has borrowed before I<$date> and the borrowernumber.
1955 sub GetBorrowersNamesAndLatestIssue {
1956 my $dbh = C4::Context->dbh;
1957 my @borrowernumbers=@_;
1959 SELECT surname,lastname, phone, email,max(timestamp)
1961 LEFT JOIN issues ON borrowers.borrowernumber=issues.borrowernumber
1962 GROUP BY borrowernumber
1964 my $sth = $dbh->prepare($query);
1966 my $results = $sth->fetchall_arrayref({});
1972 IssueSlip($branchcode, $borrowernumber, $quickslip)
1974 Returns letter hash ( see C4::Letters::GetPreparedLetter )
1976 $quickslip is boolean, to indicate whether we want a quick slip
1978 IssueSlip populates ISSUESLIP and ISSUEQSLIP, and will make the following expansions:
2014 NOTE: Not all table fields are available, pleasee see GetPendingIssues for a list of available fields.
2019 my ($branch, $borrowernumber, $quickslip) = @_;
2021 # FIXME Check callers before removing this statement
2022 #return unless $borrowernumber;
2024 my @issues = @{ GetPendingIssues($borrowernumber) };
2026 for my $issue (@issues) {
2027 $issue->{date_due} = $issue->{date_due_sql};
2029 my $today = output_pref({ dt => dt_from_string, dateformat => 'iso', dateonly => 1 });
2030 if ( substr( $issue->{issuedate}, 0, 10 ) eq $today
2031 or substr( $issue->{lastreneweddate}, 0, 10 ) eq $today ) {
2037 # Sort on timestamp then on issuedate (useful for tests and could be if modified in a batch
2039 my $s = $b->{timestamp} <=> $a->{timestamp};
2041 $b->{issuedate} <=> $a->{issuedate} : $s;
2044 my ($letter_code, %repeat);
2046 $letter_code = 'ISSUEQSLIP';
2048 'checkedout' => [ map {
2051 'biblioitems' => $_,
2053 }, grep { $_->{'now'} } @issues ],
2057 $letter_code = 'ISSUESLIP';
2059 'checkedout' => [ map {
2062 'biblioitems' => $_,
2064 }, grep { !$_->{'overdue'} } @issues ],
2066 'overdue' => [ map {
2069 'biblioitems' => $_,
2071 }, grep { $_->{'overdue'} } @issues ],
2074 $_->{'timestamp'} = $_->{'newdate'};
2076 } @{ GetNewsToDisplay("slip",$branch) } ],
2080 return C4::Letters::GetPreparedLetter (
2081 module => 'circulation',
2082 letter_code => $letter_code,
2083 branchcode => $branch,
2085 'branches' => $branch,
2086 'borrowers' => $borrowernumber,
2092 =head2 GetBorrowersWithEmail
2094 ([$borrnum,$userid], ...) = GetBorrowersWithEmail('me@example.com');
2096 This gets a list of users and their basic details from their email address.
2097 As it's possible for multiple user to have the same email address, it provides
2098 you with all of them. If there is no userid for the user, there will be an
2099 C<undef> there. An empty list will be returned if there are no matches.
2103 sub GetBorrowersWithEmail {
2106 my $dbh = C4::Context->dbh;
2108 my $query = "SELECT borrowernumber, userid FROM borrowers WHERE email=?";
2109 my $sth=$dbh->prepare($query);
2110 $sth->execute($email);
2112 while (my $ref = $sth->fetch) {
2115 die "Failure searching for borrowers by email address: $sth->errstr" if $sth->err;
2119 =head2 AddMember_Opac
2123 sub AddMember_Opac {
2124 my ( %borrower ) = @_;
2126 $borrower{'categorycode'} //= C4::Context->preference('PatronSelfRegistrationDefaultCategory');
2127 if (not defined $borrower{'password'}){
2128 my $sr = new String::Random;
2129 $sr->{'A'} = [ 'A'..'Z', 'a'..'z' ];
2130 my $password = $sr->randpattern("AAAAAAAAAA");
2131 $borrower{'password'} = $password;
2134 $borrower{'cardnumber'} = fixup_cardnumber( $borrower{'cardnumber'} );
2136 my $borrowernumber = AddMember(%borrower);
2138 return ( $borrowernumber, $borrower{'password'} );
2141 =head2 AddEnrolmentFeeIfNeeded
2143 AddEnrolmentFeeIfNeeded( $borrower->{categorycode}, $borrower->{borrowernumber} );
2145 Add enrolment fee for a patron if needed.
2149 sub AddEnrolmentFeeIfNeeded {
2150 my ( $categorycode, $borrowernumber ) = @_;
2151 # check for enrollment fee & add it if needed
2152 my $dbh = C4::Context->dbh;
2153 my $sth = $dbh->prepare(q{
2156 WHERE categorycode=?
2158 $sth->execute( $categorycode );
2160 warn sprintf('Database returned the following error: %s', $sth->errstr);
2163 my ($enrolmentfee) = $sth->fetchrow;
2164 if ($enrolmentfee && $enrolmentfee > 0) {
2165 # insert fee in patron debts
2166 C4::Accounts::manualinvoice( $borrowernumber, '', '', 'A', $enrolmentfee );
2175 my ( $borrowernumber ) = @_;
2177 my $sql = "SELECT COUNT(*) FROM issues WHERE date_due < NOW() AND borrowernumber = ?";
2178 my $sth = C4::Context->dbh->prepare( $sql );
2179 $sth->execute( $borrowernumber );
2180 my ( $count ) = $sth->fetchrow_array();
2185 =head2 DeleteExpiredOpacRegistrations
2187 Delete accounts that haven't been upgraded from the 'temporary' category
2188 Returns the number of removed patrons
2192 sub DeleteExpiredOpacRegistrations {
2194 my $delay = C4::Context->preference('PatronSelfRegistrationExpireTemporaryAccountsDelay');
2195 my $category_code = C4::Context->preference('PatronSelfRegistrationDefaultCategory');
2197 return 0 if not $category_code or not defined $delay or $delay eq q||;
2200 SELECT borrowernumber
2202 WHERE categorycode = ? AND DATEDIFF( NOW(), dateenrolled ) > ? |;
2204 my $dbh = C4::Context->dbh;
2205 my $sth = $dbh->prepare($query);
2206 $sth->execute( $category_code, $delay );
2208 while ( my ($borrowernumber) = $sth->fetchrow_array() ) {
2209 DelMember($borrowernumber);
2215 =head2 DeleteUnverifiedOpacRegistrations
2217 Delete all unverified self registrations in borrower_modifications,
2218 older than the specified number of days.
2222 sub DeleteUnverifiedOpacRegistrations {
2224 my $dbh = C4::Context->dbh;
2226 DELETE FROM borrower_modifications
2227 WHERE borrowernumber = 0 AND DATEDIFF( NOW(), timestamp ) > ?|;
2228 my $cnt=$dbh->do($sql, undef, ($days) );
2229 return $cnt eq '0E0'? 0: $cnt;
2232 sub GetOverduesForPatron {
2233 my ( $borrowernumber ) = @_;
2237 FROM issues, items, biblio, biblioitems
2238 WHERE items.itemnumber=issues.itemnumber
2239 AND biblio.biblionumber = items.biblionumber
2240 AND biblio.biblionumber = biblioitems.biblionumber
2241 AND issues.borrowernumber = ?
2242 AND date_due < NOW()
2245 my $sth = C4::Context->dbh->prepare( $sql );
2246 $sth->execute( $borrowernumber );
2248 return $sth->fetchall_arrayref({});
2251 END { } # module clean-up code here (global destructor)