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
81 GetBorrowerCategorycode
83 &GetBorrowersToExpunge
84 &GetBorrowersWhoHaveNeverBorrowed
85 &GetBorrowersWithIssuesHistoryOlderThan
88 &GetUpcomingMembershipExpires
113 &ExtendMemberSubscriptionTo
129 C4::Members - Perl Module containing convenience functions for member handling
137 This module contains routines for adding, modifying and deleting members/patrons/borrowers
141 =head2 GetMemberDetails
143 ($borrower) = &GetMemberDetails($borrowernumber, $cardnumber);
145 Looks up a patron and returns information about him or her. If
146 C<$borrowernumber> is true (nonzero), C<&GetMemberDetails> looks
147 up the borrower by number; otherwise, it looks up the borrower by card
150 C<$borrower> is a reference-to-hash whose keys are the fields of the
151 borrowers table in the Koha database. In addition,
152 C<$borrower-E<gt>{flags}> is a hash giving more detailed information
153 about the patron. Its keys act as flags :
155 if $borrower->{flags}->{LOST} {
156 # Patron's card was reported lost
159 If the state of a flag means that the patron should not be
160 allowed to borrow any more books, then it will have a C<noissues> key
163 See patronflags for more details.
165 C<$borrower-E<gt>{authflags}> is a hash giving more detailed information
166 about the top-level permissions flags set for the borrower. For example,
167 if a user has the "editcatalogue" permission,
168 C<$borrower-E<gt>{authflags}-E<gt>{editcatalogue}> will exist and have
173 sub GetMemberDetails
{
174 my ( $borrowernumber, $cardnumber ) = @_;
175 my $dbh = C4
::Context
->dbh;
178 if ($borrowernumber) {
179 $sth = $dbh->prepare("
182 categories.description,
183 categories.BlockExpiredPatronOpacActions,
187 LEFT JOIN categories ON borrowers.categorycode=categories.categorycode
188 WHERE borrowernumber = ?
190 $sth->execute($borrowernumber);
192 elsif ($cardnumber) {
193 $sth = $dbh->prepare("
196 categories.description,
197 categories.BlockExpiredPatronOpacActions,
201 LEFT JOIN categories ON borrowers.categorycode = categories.categorycode
204 $sth->execute($cardnumber);
209 my $borrower = $sth->fetchrow_hashref;
210 return unless $borrower;
211 my ($amount) = GetMemberAccountRecords
($borrower->{borrowernumber
});
212 $borrower->{'amountoutstanding'} = $amount;
213 # FIXME - patronflags calls GetMemberAccountRecords... just have patronflags return $amount
214 my $flags = patronflags
( $borrower);
217 $sth = $dbh->prepare("select bit,flag from userflags");
219 while ( my ( $bit, $flag ) = $sth->fetchrow ) {
220 if ( $borrower->{'flags'} && $borrower->{'flags'} & 2**$bit ) {
221 $accessflagshash->{$flag} = 1;
224 $borrower->{'flags'} = $flags;
225 $borrower->{'authflags'} = $accessflagshash;
227 # Handle setting the true behavior for BlockExpiredPatronOpacActions
228 $borrower->{'BlockExpiredPatronOpacActions'} =
229 C4
::Context
->preference('BlockExpiredPatronOpacActions')
230 if ( $borrower->{'BlockExpiredPatronOpacActions'} == -1 );
232 $borrower->{'is_expired'} = 0;
233 $borrower->{'is_expired'} = 1 if
234 defined($borrower->{dateexpiry
}) &&
235 $borrower->{'dateexpiry'} ne '0000-00-00' &&
236 Date_to_Days
( Today
() ) >
237 Date_to_Days
( split /-/, $borrower->{'dateexpiry'} );
239 return ($borrower); #, $flags, $accessflagshash);
244 $flags = &patronflags($patron);
246 This function is not exported.
248 The following will be set where applicable:
249 $flags->{CHARGES}->{amount} Amount of debt
250 $flags->{CHARGES}->{noissues} Set if debt amount >$5.00 (or syspref noissuescharge)
251 $flags->{CHARGES}->{message} Message -- deprecated
253 $flags->{CREDITS}->{amount} Amount of credit
254 $flags->{CREDITS}->{message} Message -- deprecated
256 $flags->{ GNA } Patron has no valid address
257 $flags->{ GNA }->{noissues} Set for each GNA
258 $flags->{ GNA }->{message} "Borrower has no valid address" -- deprecated
260 $flags->{ LOST } Patron's card reported lost
261 $flags->{ LOST }->{noissues} Set for each LOST
262 $flags->{ LOST }->{message} Message -- deprecated
264 $flags->{DBARRED} Set if patron debarred, no access
265 $flags->{DBARRED}->{noissues} Set for each DBARRED
266 $flags->{DBARRED}->{message} Message -- deprecated
269 $flags->{ NOTES }->{message} The note itself. NOT deprecated
271 $flags->{ ODUES } Set if patron has overdue books.
272 $flags->{ ODUES }->{message} "Yes" -- deprecated
273 $flags->{ ODUES }->{itemlist} ref-to-array: list of overdue books
274 $flags->{ ODUES }->{itemlisttext} Text list of overdue items -- deprecated
276 $flags->{WAITING} Set if any of patron's reserves are available
277 $flags->{WAITING}->{message} Message -- deprecated
278 $flags->{WAITING}->{itemlist} ref-to-array: list of available items
282 =item C<$flags-E<gt>{ODUES}-E<gt>{itemlist}> is a reference-to-array listing the
283 overdue items. Its elements are references-to-hash, each describing an
284 overdue item. The keys are selected fields from the issues, biblio,
285 biblioitems, and items tables of the Koha database.
287 =item C<$flags-E<gt>{ODUES}-E<gt>{itemlisttext}> is a string giving a text listing of
288 the overdue items, one per line. Deprecated.
290 =item C<$flags-E<gt>{WAITING}-E<gt>{itemlist}> is a reference-to-array listing the
291 available items. Each element is a reference-to-hash whose keys are
292 fields from the reserves table of the Koha database.
296 All the "message" fields that include language generated in this function are deprecated,
297 because such strings belong properly in the display layer.
299 The "message" field that comes from the DB is OK.
303 # TODO: use {anonymous => hashes} instead of a dozen %flaginfo
304 # FIXME rename this function.
307 my ( $patroninformation) = @_;
308 my $dbh=C4
::Context
->dbh;
309 my ($balance, $owing) = GetMemberAccountBalance
( $patroninformation->{'borrowernumber'});
312 my $noissuescharge = C4
::Context
->preference("noissuescharge") || 5;
313 $flaginfo{'message'} = sprintf 'Patron owes %.02f', $owing;
314 $flaginfo{'amount'} = sprintf "%.02f", $owing;
315 if ( $owing > $noissuescharge && !C4
::Context
->preference("AllowFineOverride") ) {
316 $flaginfo{'noissues'} = 1;
318 $flags{'CHARGES'} = \
%flaginfo;
320 elsif ( $balance < 0 ) {
322 $flaginfo{'message'} = sprintf 'Patron has credit of %.02f', -$balance;
323 $flaginfo{'amount'} = sprintf "%.02f", $balance;
324 $flags{'CREDITS'} = \
%flaginfo;
327 # Check the debt of the guarntees of this patron
328 my $no_issues_charge_guarantees = C4
::Context
->preference("NoIssuesChargeGuarantees");
329 $no_issues_charge_guarantees = undef unless looks_like_number
( $no_issues_charge_guarantees );
330 if ( defined $no_issues_charge_guarantees ) {
331 my $p = Koha
::Patrons
->find( $patroninformation->{borrowernumber
} );
332 my @guarantees = $p->guarantees();
333 my $guarantees_non_issues_charges;
334 foreach my $g ( @guarantees ) {
335 my ( $b, $n, $o ) = C4
::Members
::GetMemberAccountBalance
( $g->id );
336 $guarantees_non_issues_charges += $n;
339 if ( $guarantees_non_issues_charges > $no_issues_charge_guarantees ) {
341 $flaginfo{'message'} = sprintf 'patron guarantees owe %.02f', $guarantees_non_issues_charges;
342 $flaginfo{'amount'} = $guarantees_non_issues_charges;
343 $flaginfo{'noissues'} = 1 unless C4
::Context
->preference("allowfineoverride");
344 $flags{'CHARGES_GUARANTEES'} = \
%flaginfo;
348 if ( $patroninformation->{'gonenoaddress'}
349 && $patroninformation->{'gonenoaddress'} == 1 )
352 $flaginfo{'message'} = 'Borrower has no valid address.';
353 $flaginfo{'noissues'} = 1;
354 $flags{'GNA'} = \
%flaginfo;
356 if ( $patroninformation->{'lost'} && $patroninformation->{'lost'} == 1 ) {
358 $flaginfo{'message'} = 'Borrower\'s card reported lost.';
359 $flaginfo{'noissues'} = 1;
360 $flags{'LOST'} = \
%flaginfo;
362 if ( $patroninformation->{'debarred'} && check_date
( split( /-/, $patroninformation->{'debarred'} ) ) ) {
363 if ( Date_to_Days
(Date
::Calc
::Today
) < Date_to_Days
( split( /-/, $patroninformation->{'debarred'} ) ) ) {
365 $flaginfo{'debarredcomment'} = $patroninformation->{'debarredcomment'};
366 $flaginfo{'message'} = $patroninformation->{'debarredcomment'};
367 $flaginfo{'noissues'} = 1;
368 $flaginfo{'dateend'} = $patroninformation->{'debarred'};
369 $flags{'DBARRED'} = \
%flaginfo;
372 if ( $patroninformation->{'borrowernotes'}
373 && $patroninformation->{'borrowernotes'} )
376 $flaginfo{'message'} = $patroninformation->{'borrowernotes'};
377 $flags{'NOTES'} = \
%flaginfo;
379 my ( $odues, $itemsoverdue ) = C4
::Overdues
::checkoverdues
($patroninformation->{'borrowernumber'});
380 if ( $odues && $odues > 0 ) {
382 $flaginfo{'message'} = "Yes";
383 $flaginfo{'itemlist'} = $itemsoverdue;
384 foreach ( sort { $a->{'date_due'} cmp $b->{'date_due'} }
387 $flaginfo{'itemlisttext'} .=
388 "$_->{'date_due'} $_->{'barcode'} $_->{'title'} \n"; # newline is display layer
390 $flags{'ODUES'} = \
%flaginfo;
392 my @itemswaiting = C4
::Reserves
::GetReservesFromBorrowernumber
( $patroninformation->{'borrowernumber'},'W' );
393 my $nowaiting = scalar @itemswaiting;
394 if ( $nowaiting > 0 ) {
396 $flaginfo{'message'} = "Reserved items available";
397 $flaginfo{'itemlist'} = \
@itemswaiting;
398 $flags{'WAITING'} = \
%flaginfo;
406 $borrower = &GetMember(%information);
408 Retrieve the first patron record meeting on criteria listed in the
409 C<%information> hash, which should contain one or more
410 pairs of borrowers column names and values, e.g.,
412 $borrower = GetMember(borrowernumber => id);
414 C<&GetBorrower> returns a reference-to-hash whose keys are the fields of
415 the C<borrowers> table in the Koha database.
417 FIXME: GetMember() is used throughout the code as a lookup
418 on a unique key such as the borrowernumber, but this meaning is not
419 enforced in the routine itself.
425 my ( %information ) = @_;
426 if (exists $information{borrowernumber
} && !defined $information{borrowernumber
}) {
427 #passing mysql's kohaadmin?? Makes no sense as a query
430 my $dbh = C4
::Context
->dbh;
432 q{SELECT borrowers.*, categories.category_type, categories.description
434 LEFT JOIN categories on borrowers.categorycode=categories.categorycode WHERE };
437 for (keys %information ) {
445 if (defined $information{$_}) {
447 push @values, $information{$_};
450 $select .= "$_ IS NULL";
453 $debug && warn $select, " ",values %information;
454 my $sth = $dbh->prepare("$select");
455 $sth->execute(@values);
456 my $data = $sth->fetchall_arrayref({});
457 #FIXME interface to this routine now allows generation of a result set
458 #so whole array should be returned but bowhere in the current code expects this
466 =head2 IsMemberBlocked
468 my ($block_status, $count) = IsMemberBlocked( $borrowernumber );
470 Returns whether a patron is restricted or has overdue items that may result
471 in a block of circulation privileges.
473 C<$block_status> can have the following values:
475 1 if the patron is currently restricted, in which case
476 C<$count> is the expiration date (9999-12-31 for indefinite)
478 -1 if the patron has overdue items, in which case C<$count> is the number of them
480 0 if the patron has no overdue items or outstanding fine days, in which case C<$count> is 0
482 Existing active restrictions are checked before current overdue items.
486 sub IsMemberBlocked
{
487 my $borrowernumber = shift;
488 my $dbh = C4
::Context
->dbh;
490 my $blockeddate = Koha
::Patrons
->find( $borrowernumber )->is_debarred;
492 return ( 1, $blockeddate ) if $blockeddate;
494 # if he have late issues
495 my $sth = $dbh->prepare(
496 "SELECT COUNT(*) as latedocs
498 WHERE borrowernumber = ?
499 AND date_due < now()"
501 $sth->execute($borrowernumber);
502 my $latedocs = $sth->fetchrow_hashref->{'latedocs'};
504 return ( -1, $latedocs ) if $latedocs > 0;
509 =head2 GetMemberIssuesAndFines
511 ($overdue_count, $issue_count, $total_fines) = &GetMemberIssuesAndFines($borrowernumber);
513 Returns aggregate data about items borrowed by the patron with the
514 given borrowernumber.
516 C<&GetMemberIssuesAndFines> returns a three-element array. C<$overdue_count> is the
517 number of overdue items the patron currently has borrowed. C<$issue_count> is the
518 number of books the patron currently has borrowed. C<$total_fines> is
519 the total fine currently due by the borrower.
524 sub GetMemberIssuesAndFines
{
525 my ( $borrowernumber ) = @_;
526 my $dbh = C4
::Context
->dbh;
527 my $query = "SELECT COUNT(*) FROM issues WHERE borrowernumber = ?";
529 $debug and warn $query."\n";
530 my $sth = $dbh->prepare($query);
531 $sth->execute($borrowernumber);
532 my $issue_count = $sth->fetchrow_arrayref->[0];
534 $sth = $dbh->prepare(
535 "SELECT COUNT(*) FROM issues
536 WHERE borrowernumber = ?
537 AND date_due < now()"
539 $sth->execute($borrowernumber);
540 my $overdue_count = $sth->fetchrow_arrayref->[0];
542 $sth = $dbh->prepare("SELECT SUM(amountoutstanding) FROM accountlines WHERE borrowernumber = ?");
543 $sth->execute($borrowernumber);
544 my $total_fines = $sth->fetchrow_arrayref->[0];
546 return ($overdue_count, $issue_count, $total_fines);
552 my $success = ModMember(borrowernumber => $borrowernumber,
553 [ field => value ]... );
555 Modify borrower's data. All date fields should ALREADY be in ISO format.
558 true on success, or false on failure
564 # test to know if you must update or not the borrower password
565 if (exists $data{password
}) {
566 if ($data{password
} eq '****' or $data{password
} eq '') {
567 delete $data{password
};
569 if ( C4
::Context
->preference('NorwegianPatronDBEnable') && C4
::Context
->preference('NorwegianPatronDBEnable') == 1 ) {
570 # Update the hashed PIN in borrower_sync.hashed_pin, before Koha hashes it
571 Koha
::NorwegianPatronDB
::NLUpdateHashedPIN
( $data{'borrowernumber'}, $data{password
} );
573 $data{password
} = hash_password
($data{password
});
577 my $old_categorycode = GetBorrowerCategorycode
( $data{borrowernumber
} );
579 # get only the columns of a borrower
580 my $schema = Koha
::Database
->new()->schema;
581 my @columns = $schema->source('Borrower')->columns;
582 my $new_borrower = { map { join(' ', @columns) =~ /$_/ ?
( $_ => $data{$_} ) : () } keys(%data) };
583 delete $new_borrower->{flags
};
585 $new_borrower->{dateofbirth
} ||= undef if exists $new_borrower->{dateofbirth
};
586 $new_borrower->{dateenrolled
} ||= undef if exists $new_borrower->{dateenrolled
};
587 $new_borrower->{dateexpiry
} ||= undef if exists $new_borrower->{dateexpiry
};
588 $new_borrower->{debarred
} ||= undef if exists $new_borrower->{debarred
};
589 $new_borrower->{sms_provider_id
} ||= undef if exists $new_borrower->{sms_provider_id
};
591 my $rs = $schema->resultset('Borrower')->search({
592 borrowernumber
=> $new_borrower->{borrowernumber
},
595 delete $new_borrower->{userid
} if exists $new_borrower->{userid
} and not $new_borrower->{userid
};
597 my $execute_success = $rs->update($new_borrower);
598 if ($execute_success ne '0E0') { # only proceed if the update was a success
599 # If the patron changes to a category with enrollment fee, we add a fee
600 if ( $data{categorycode
} and $data{categorycode
} ne $old_categorycode ) {
601 if ( C4
::Context
->preference('FeeOnChangePatronCategory') ) {
602 AddEnrolmentFeeIfNeeded
( $data{categorycode
}, $data{borrowernumber
} );
606 # If NorwegianPatronDBEnable is enabled, we set syncstatus to something that a
607 # cronjob will use for syncing with NL
608 if ( C4
::Context
->preference('NorwegianPatronDBEnable') && C4
::Context
->preference('NorwegianPatronDBEnable') == 1 ) {
609 my $borrowersync = Koha
::Database
->new->schema->resultset('BorrowerSync')->find({
610 'synctype' => 'norwegianpatrondb',
611 'borrowernumber' => $data{'borrowernumber'}
613 # Do not set to "edited" if syncstatus is "new". We need to sync as new before
614 # we can sync as changed. And the "new sync" will pick up all changes since
615 # the patron was created anyway.
616 if ( $borrowersync->syncstatus ne 'new' && $borrowersync->syncstatus ne 'delete' ) {
617 $borrowersync->update( { 'syncstatus' => 'edited' } );
619 # Set the value of 'sync'
620 $borrowersync->update( { 'sync' => $data{'sync'} } );
621 # Try to do the live sync
622 Koha
::NorwegianPatronDB
::NLSync
({ 'borrowernumber' => $data{'borrowernumber'} });
625 logaction
("MEMBERS", "MODIFY", $data{'borrowernumber'}, "UPDATE (executed w/ arg: $data{'borrowernumber'})") if C4
::Context
->preference("BorrowersLog");
627 return $execute_success;
632 $borrowernumber = &AddMember(%borrower);
634 insert new borrower into table
636 (%borrower keys are database columns. Database columns could be
637 different in different versions. Please look into database for correct
640 Returns the borrowernumber upon success
642 Returns as undef upon any db error without further processing
649 my $dbh = C4
::Context
->dbh;
650 my $schema = Koha
::Database
->new()->schema;
652 # generate a proper login if none provided
653 $data{'userid'} = Generate_Userid
( $data{'borrowernumber'}, $data{'firstname'}, $data{'surname'} )
654 if ( $data{'userid'} eq '' || !Check_Userid
( $data{'userid'} ) );
656 # add expiration date if it isn't already there
657 unless ( $data{'dateexpiry'} ) {
658 $data{'dateexpiry'} = GetExpiryDate
( $data{'categorycode'}, output_pref
( { dt
=> dt_from_string
, dateonly
=> 1, dateformat
=> 'iso' } ) );
661 # add enrollment date if it isn't already there
662 unless ( $data{'dateenrolled'} ) {
663 $data{'dateenrolled'} = output_pref
( { dt
=> dt_from_string
, dateonly
=> 1, dateformat
=> 'iso' } );
666 my $patron_category = $schema->resultset('Category')->find( $data{'categorycode'} );
668 $patron_category->default_privacy() eq 'default' ?
1
669 : $patron_category->default_privacy() eq 'never' ?
2
670 : $patron_category->default_privacy() eq 'forever' ?
0
673 $data{'privacy_guarantor_checkouts'} = 0 unless defined( $data{'privacy_guarantor_checkouts'} );
675 # Make a copy of the plain text password for later use
676 my $plain_text_password = $data{'password'};
678 # create a disabled account if no password provided
679 $data{'password'} = ($data{'password'})? hash_password
($data{'password'}) : '!';
681 # we don't want invalid dates in the db (mysql has a bad habit of inserting 0000-00-00
682 $data{'dateofbirth'} = undef if ( not $data{'dateofbirth'} );
683 $data{'debarred'} = undef if ( not $data{'debarred'} );
684 $data{'sms_provider_id'} = undef if ( not $data{'sms_provider_id'} );
686 # get only the columns of Borrower
687 my @columns = $schema->source('Borrower')->columns;
688 my $new_member = { map { join(' ',@columns) =~ /$_/ ?
( $_ => $data{$_} ) : () } keys(%data) } ;
689 $new_member->{checkprevcheckout
} ||= 'inherit';
690 delete $new_member->{borrowernumber
};
692 my $rs = $schema->resultset('Borrower');
693 $data{borrowernumber
} = $rs->create($new_member)->id;
695 # If NorwegianPatronDBEnable is enabled, we set syncstatus to something that a
696 # cronjob will use for syncing with NL
697 if ( exists $data{'borrowernumber'} && C4
::Context
->preference('NorwegianPatronDBEnable') && C4
::Context
->preference('NorwegianPatronDBEnable') == 1 ) {
698 Koha
::Database
->new->schema->resultset('BorrowerSync')->create({
699 'borrowernumber' => $data{'borrowernumber'},
700 'synctype' => 'norwegianpatrondb',
702 'syncstatus' => 'new',
703 'hashed_pin' => Koha
::NorwegianPatronDB
::NLEncryptPIN
( $plain_text_password ),
707 # mysql_insertid is probably bad. not necessarily accurate and mysql-specific at best.
708 logaction
("MEMBERS", "CREATE", $data{'borrowernumber'}, "") if C4
::Context
->preference("BorrowersLog");
710 AddEnrolmentFeeIfNeeded
( $data{categorycode
}, $data{borrowernumber
} );
712 return $data{borrowernumber
};
717 my $uniqueness = Check_Userid($userid,$borrowernumber);
719 $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 != '').
721 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.
724 0 for not unique (i.e. this $userid already exists)
725 1 for unique (i.e. this $userid does not exist, or this $userid/$borrowernumber combination already exists)
730 my ( $uid, $borrowernumber ) = @_;
732 return 0 unless ($uid); # userid is a unique column, we should assume NULL is not unique
734 return 0 if ( $uid eq C4
::Context
->config('user') );
736 my $rs = Koha
::Database
->new()->schema()->resultset('Borrower');
739 $params->{userid
} = $uid;
740 $params->{borrowernumber
} = { '!=' => $borrowernumber } if ($borrowernumber);
742 my $count = $rs->count( $params );
744 return $count ?
0 : 1;
747 =head2 Generate_Userid
749 my $newuid = Generate_Userid($borrowernumber, $firstname, $surname);
751 Generate a userid using the $surname and the $firstname (if there is a value in $firstname).
753 $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.
756 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).
760 sub Generate_Userid
{
761 my ($borrowernumber, $firstname, $surname) = @_;
764 #The script will "do" the following code and increment the $offset until Check_Userid = 1 (i.e. until $newuid comes back as unique)
766 $firstname =~ s/[[:digit:][:space:][:blank:][:punct:][:cntrl:]]//g;
767 $surname =~ s/[[:digit:][:space:][:blank:][:punct:][:cntrl:]]//g;
768 $newuid = lc(($firstname)?
"$firstname.$surname" : $surname);
769 $newuid = unac_string
('utf-8',$newuid);
770 $newuid .= $offset unless $offset == 0;
773 } while (!Check_Userid
($newuid,$borrowernumber));
778 =head2 fixup_cardnumber
780 Warning: The caller is responsible for locking the members table in write
781 mode, to avoid database corruption.
785 use vars
qw( @weightings );
786 my @weightings = ( 8, 4, 6, 3, 5, 2, 1 );
788 sub fixup_cardnumber {
789 my ($cardnumber) = @_;
790 my $autonumber_members = C4::Context->boolean_preference('autoMemberNum') || 0;
792 # Find out whether member numbers should be generated
793 # automatically. Should be either "1" or something else.
794 # Defaults to "0", which is interpreted as "no".
796 # if ($cardnumber !~ /\S/ && $autonumber_members) {
797 ($autonumber_members) or return $cardnumber;
798 my $checkdigit = C4::Context->preference('checkdigit');
799 my $dbh = C4::Context->dbh;
800 if ( $checkdigit and $checkdigit eq 'katipo' ) {
802 # if checkdigit is selected, calculate katipo-style cardnumber.
803 # otherwise, just use the max()
804 # purpose: generate checksum'd member numbers.
805 # We'll assume we just got the max value of digits 2-8 of member #'s
806 # from the database and our job is to increment that by one,
807 # determine the 1st and 9th digits and return the full string.
808 my $sth = $dbh->prepare(
809 "select max(substring(borrowers.cardnumber,2,7)) as new_num from borrowers"
812 my $data = $sth->fetchrow_hashref;
813 $cardnumber = $data->{new_num};
814 if ( !$cardnumber ) { # If DB has no values,
815 $cardnumber = 1000000; # start at 1000000
821 for ( my $i = 0 ; $i < 8 ; $i += 1 ) {
822 # read weightings, left to right, 1 char at a time
823 my $temp1 = $weightings[$i];
825 # sequence left to right, 1 char at a time
826 my $temp2 = substr( $cardnumber, $i, 1 );
828 # mult each char 1-7 by its corresponding weighting
829 $sum += $temp1 * $temp2;
832 my $rem = ( $sum % 11 );
833 $rem = 'X' if $rem == 10;
835 return "V$cardnumber$rem";
838 my $sth = $dbh->prepare(
839 'SELECT MAX( CAST( cardnumber AS SIGNED ) ) FROM borrowers WHERE cardnumber REGEXP "^-?[0-9]+$"'
842 my ($result) = $sth->fetchrow;
845 return $cardnumber; # just here as a fallback/reminder
848 =head2 GetPendingIssues
850 my $issues = &GetPendingIssues(@borrowernumber);
852 Looks up what the patron with the given borrowernumber has borrowed.
854 C<&GetPendingIssues> returns a
855 reference-to-array where each element is a reference-to-hash; the
856 keys are the fields from the C<issues>, C<biblio>, and C<items> tables.
857 The keys include C<biblioitems> fields except marc and marcxml.
861 sub GetPendingIssues {
862 my @borrowernumbers = @_;
864 unless (@borrowernumbers ) { # return a ref_to_array
865 return \@borrowernumbers; # to not cause surprise to caller
868 # Borrowers part of the query
870 for (my $i = 0; $i < @borrowernumbers; $i++) {
871 $bquery .= ' issues.borrowernumber = ?';
872 if ($i < $#borrowernumbers ) {
877 # must avoid biblioitems.* to prevent large marc and marcxml fields from killing performance
878 # FIXME: namespace collision: each table has "timestamp" fields. Which one is "timestamp" ?
879 # FIXME: circ/ciculation.pl tries to sort by timestamp!
880 # FIXME: namespace collision: other collisions possible.
881 # FIXME: most of this data isn't really being used by callers.
888 biblioitems.itemtype,
891 biblioitems.publicationyear,
892 biblioitems.publishercode,
893 biblioitems.volumedate,
894 biblioitems.volumedesc,
899 borrowers.cardnumber,
900 issues.timestamp AS timestamp,
901 issues.renewals AS renewals,
902 issues.borrowernumber AS borrowernumber,
903 items.renewals AS totalrenewals
905 LEFT JOIN items ON items.itemnumber = issues.itemnumber
906 LEFT JOIN biblio ON items.biblionumber = biblio.biblionumber
907 LEFT JOIN biblioitems ON items.biblioitemnumber = biblioitems.biblioitemnumber
908 LEFT JOIN borrowers ON issues.borrowernumber = borrowers.borrowernumber
911 ORDER BY issues.issuedate"
914 my $sth = C4::Context->dbh->prepare($query);
915 $sth->execute(@borrowernumbers);
916 my $data = $sth->fetchall_arrayref({});
917 my $today = dt_from_string;
919 if ($_->{issuedate}) {
920 $_->{issuedate} = dt_from_string($_->{issuedate}, 'sql');
922 $_->{date_due_sql} = $_->{date_due};
923 # FIXME no need to have this value
924 $_->{date_due} or next;
925 $_->{date_due_sql} = $_->{date_due};
926 # FIXME no need to have this value
927 $_->{date_due} = dt_from_string($_->{date_due}, 'sql');
928 if ( DateTime->compare($_->{date_due}, $today) == -1 ) {
937 $issues = &GetAllIssues($borrowernumber, $sortkey, $limit);
939 Looks up what the patron with the given borrowernumber has borrowed,
940 and sorts the results.
942 C<$sortkey> is the name of a field on which to sort the results. This
943 should be the name of a field in the C<issues>, C<biblio>,
944 C<biblioitems>, or C<items> table in the Koha database.
946 C<$limit> is the maximum number of results to return.
948 C<&GetAllIssues> an arrayref, C<$issues>, of hashrefs, the keys of which
949 are the fields from the C<issues>, C<biblio>, C<biblioitems>, and
950 C<items> tables of the Koha database.
956 my ( $borrowernumber, $order, $limit ) = @_;
958 return unless $borrowernumber;
959 $order = 'date_due desc' unless $order;
961 my $dbh = C4::Context->dbh;
963 'SELECT *, issues.timestamp as issuestimestamp, issues.renewals AS renewals,items.renewals AS totalrenewals,items.timestamp AS itemstimestamp
965 LEFT JOIN items on items.itemnumber=issues.itemnumber
966 LEFT JOIN biblio ON items.biblionumber=biblio.biblionumber
967 LEFT JOIN biblioitems ON items.biblioitemnumber=biblioitems.biblioitemnumber
968 WHERE borrowernumber=?
970 SELECT *, old_issues.timestamp as issuestimestamp, old_issues.renewals AS renewals,items.renewals AS totalrenewals,items.timestamp AS itemstimestamp
972 LEFT JOIN items on items.itemnumber=old_issues.itemnumber
973 LEFT JOIN biblio ON items.biblionumber=biblio.biblionumber
974 LEFT JOIN biblioitems ON items.biblioitemnumber=biblioitems.biblioitemnumber
975 WHERE borrowernumber=? AND old_issues.itemnumber IS NOT NULL
978 $query .= " limit $limit";
981 my $sth = $dbh->prepare($query);
982 $sth->execute( $borrowernumber, $borrowernumber );
983 return $sth->fetchall_arrayref( {} );
987 =head2 GetMemberAccountRecords
989 ($total, $acctlines, $count) = &GetMemberAccountRecords($borrowernumber);
991 Looks up accounting data for the patron with the given borrowernumber.
993 C<&GetMemberAccountRecords> returns a three-element array. C<$acctlines> is a
994 reference-to-array, where each element is a reference-to-hash; the
995 keys are the fields of the C<accountlines> table in the Koha database.
996 C<$count> is the number of elements in C<$acctlines>. C<$total> is the
997 total amount outstanding for all of the account lines.
1001 sub GetMemberAccountRecords {
1002 my ($borrowernumber) = @_;
1003 my $dbh = C4::Context->dbh;
1009 WHERE borrowernumber=?);
1010 $strsth.=" ORDER BY accountlines_id desc";
1011 my $sth= $dbh->prepare( $strsth );
1012 $sth->execute( $borrowernumber );
1015 while ( my $data = $sth->fetchrow_hashref ) {
1016 if ( $data->{itemnumber} ) {
1017 my $biblio = GetBiblioFromItemNumber( $data->{itemnumber} );
1018 $data->{biblionumber} = $biblio->{biblionumber};
1019 $data->{title} = $biblio->{title};
1021 $acctlines[$numlines] = $data;
1023 $total += sprintf "%.0f", 1000*$data->{amountoutstanding}; # convert float to integer to avoid round-off errors
1026 return ( $total, \@acctlines,$numlines);
1029 =head2 GetMemberAccountBalance
1031 ($total_balance, $non_issue_balance, $other_charges) = &GetMemberAccountBalance($borrowernumber);
1033 Calculates amount immediately owing by the patron - non-issue charges.
1034 Based on GetMemberAccountRecords.
1035 Charges exempt from non-issue are:
1037 * Rent (rental) if RentalsInNoissuesCharge syspref is set to false
1038 * Manual invoices if ManInvInNoissuesCharge syspref is set to false
1042 sub GetMemberAccountBalance {
1043 my ($borrowernumber) = @_;
1045 my $ACCOUNT_TYPE_LENGTH = 5; # this is plain ridiculous...
1048 push @not_fines, 'Res' unless C4::Context->preference('HoldsInNoissuesCharge');
1049 push @not_fines, 'Rent' unless C4::Context->preference('RentalsInNoissuesCharge');
1050 unless ( C4::Context->preference('ManInvInNoissuesCharge') ) {
1051 my $dbh = C4::Context->dbh;
1052 my $man_inv_types = $dbh->selectcol_arrayref(qq{SELECT authorised_value FROM authorised_values WHERE category = 'MANUAL_INV'});
1053 push @not_fines, map substr($_, 0, $ACCOUNT_TYPE_LENGTH), @$man_inv_types;
1055 my %not_fine = map {$_ => 1} @not_fines;
1057 my ($total, $acctlines) = GetMemberAccountRecords($borrowernumber);
1058 my $other_charges = 0;
1059 foreach (@$acctlines) {
1060 $other_charges += $_->{amountoutstanding} if $not_fine{ substr($_->{accounttype}, 0, $ACCOUNT_TYPE_LENGTH) };
1063 return ( $total, $total - $other_charges, $other_charges);
1066 =head2 GetBorNotifyAcctRecord
1068 ($total, $acctlines, $count) = &GetBorNotifyAcctRecord($params,$notifyid);
1070 Looks up accounting data for the patron with the given borrowernumber per file number.
1072 C<&GetBorNotifyAcctRecord> returns a three-element array. C<$acctlines> is a
1073 reference-to-array, where each element is a reference-to-hash; the
1074 keys are the fields of the C<accountlines> table in the Koha database.
1075 C<$count> is the number of elements in C<$acctlines>. C<$total> is the
1076 total amount outstanding for all of the account lines.
1080 sub GetBorNotifyAcctRecord {
1081 my ( $borrowernumber, $notifyid ) = @_;
1082 my $dbh = C4::Context->dbh;
1085 my $sth = $dbh->prepare(
1088 WHERE borrowernumber=?
1090 AND amountoutstanding != '0'
1091 ORDER BY notify_id,accounttype
1094 $sth->execute( $borrowernumber, $notifyid );
1096 while ( my $data = $sth->fetchrow_hashref ) {
1097 if ( $data->{itemnumber} ) {
1098 my $biblio = GetBiblioFromItemNumber( $data->{itemnumber} );
1099 $data->{biblionumber} = $biblio->{biblionumber};
1100 $data->{title} = $biblio->{title};
1102 $acctlines[$numlines] = $data;
1104 $total += int(100 * $data->{'amountoutstanding'});
1107 return ( $total, \@acctlines, $numlines );
1110 sub checkcardnumber {
1111 my ( $cardnumber, $borrowernumber ) = @_;
1113 # If cardnumber is null, we assume they're allowed.
1114 return 0 unless defined $cardnumber;
1116 my $dbh = C4::Context->dbh;
1117 my $query = "SELECT * FROM borrowers WHERE cardnumber=?";
1118 $query .= " AND borrowernumber <> ?" if ($borrowernumber);
1119 my $sth = $dbh->prepare($query);
1122 ( $borrowernumber ? $borrowernumber : () )
1125 return 1 if $sth->fetchrow_hashref;
1127 my ( $min_length, $max_length ) = get_cardnumber_length();
1129 if length $cardnumber > $max_length
1130 or length $cardnumber < $min_length;
1135 =head2 get_cardnumber_length
1137 my ($min, $max) = C4::Members::get_cardnumber_length()
1139 Returns the minimum and maximum length for patron cardnumbers as
1140 determined by the CardnumberLength system preference, the
1141 BorrowerMandatoryField system preference, and the width of the
1146 sub get_cardnumber_length {
1147 my ( $min, $max ) = ( 0, 16 ); # borrowers.cardnumber is a nullable varchar(16)
1148 $min = 1 if C4::Context->preference('BorrowerMandatoryField') =~ /cardnumber/;
1149 if ( my $cardnumber_length = C4::Context->preference('CardnumberLength') ) {
1150 # Is integer and length match
1151 if ( $cardnumber_length =~ m|^\d+$| ) {
1152 $min = $max = $cardnumber_length
1153 if $cardnumber_length >= $min
1154 and $cardnumber_length <= $max;
1156 # Else assuming it is a range
1157 elsif ( $cardnumber_length =~ m|(\d*),(\d*)| ) {
1158 $min = $1 if $1 and $min < $1;
1159 $max = $2 if $2 and $max > $2;
1163 return ( $min, $max );
1166 =head2 GetFirstValidEmailAddress
1168 $email = GetFirstValidEmailAddress($borrowernumber);
1170 Return the first valid email address for a borrower, given the borrowernumber. For now, the order
1171 is defined as email, emailpro, B_email. Returns the empty string if the borrower has no email
1176 sub GetFirstValidEmailAddress {
1177 my $borrowernumber = shift;
1178 my $dbh = C4::Context->dbh;
1179 my $sth = $dbh->prepare( "SELECT email, emailpro, B_email FROM borrowers where borrowernumber = ? ");
1180 $sth->execute( $borrowernumber );
1181 my $data = $sth->fetchrow_hashref;
1183 if ($data->{'email'}) {
1184 return $data->{'email'};
1185 } elsif ($data->{'emailpro'}) {
1186 return $data->{'emailpro'};
1187 } elsif ($data->{'B_email'}) {
1188 return $data->{'B_email'};
1194 =head2 GetNoticeEmailAddress
1196 $email = GetNoticeEmailAddress($borrowernumber);
1198 Return the email address of borrower used for notices, given the borrowernumber.
1199 Returns the empty string if no email address.
1203 sub GetNoticeEmailAddress {
1204 my $borrowernumber = shift;
1206 my $which_address = C4::Context->preference("AutoEmailPrimaryAddress");
1207 # if syspref is set to 'first valid' (value == OFF), look up email address
1208 if ( $which_address eq 'OFF' ) {
1209 return GetFirstValidEmailAddress($borrowernumber);
1211 # specified email address field
1212 my $dbh = C4::Context->dbh;
1213 my $sth = $dbh->prepare( qq{
1214 SELECT $which_address AS primaryemail
1216 WHERE borrowernumber=?
1218 $sth->execute($borrowernumber);
1219 my $data = $sth->fetchrow_hashref;
1220 return $data->{'primaryemail'} || '';
1223 =head2 GetExpiryDate
1225 $expirydate = GetExpiryDate($categorycode, $dateenrolled);
1227 Calculate expiry date given a categorycode and starting date. Date argument must be in ISO format.
1228 Return date is also in ISO format.
1233 my ( $categorycode, $dateenrolled ) = @_;
1235 if ($categorycode) {
1236 my $dbh = C4::Context->dbh;
1237 my $sth = $dbh->prepare("SELECT enrolmentperiod,enrolmentperioddate FROM categories WHERE categorycode=?");
1238 $sth->execute($categorycode);
1239 $enrolments = $sth->fetchrow_hashref;
1241 # die "GetExpiryDate: for enrollmentperiod $enrolmentperiod (category '$categorycode') starting $dateenrolled.\n";
1242 my @date = split (/-/,$dateenrolled);
1243 if($enrolments->{enrolmentperiod}){
1244 return sprintf("%04d-%02d-%02d", Add_Delta_YM(@date,0,$enrolments->{enrolmentperiod}));
1246 return $enrolments->{enrolmentperioddate};
1250 =head2 GetUpcomingMembershipExpires
1252 my $expires = GetUpcomingMembershipExpires({
1253 branch => $branch, before => $before, after => $after,
1256 $branch is an optional branch code.
1257 $before/$after is an optional number of days before/after the date that
1258 is set by the preference MembershipExpiryDaysNotice.
1259 If the pref would be 14, before 2 and after 3, you will get all expires
1264 sub GetUpcomingMembershipExpires {
1265 my ( $params ) = @_;
1266 my $before = $params->{before} || 0;
1267 my $after = $params->{after} || 0;
1268 my $branch = $params->{branch};
1270 my $dbh = C4::Context->dbh;
1271 my $days = C4::Context->preference("MembershipExpiryDaysNotice") || 0;
1272 my $date1 = dt_from_string->add( days => $days - $before );
1273 my $date2 = dt_from_string->add( days => $days + $after );
1274 $date1= output_pref({ dt => $date1, dateformat => 'iso', dateonly => 1 });
1275 $date2= output_pref({ dt => $date2, dateformat => 'iso', dateonly => 1 });
1278 SELECT borrowers.*, categories.description,
1279 branches.branchname, branches.branchemail FROM borrowers
1280 LEFT JOIN branches USING (branchcode)
1281 LEFT JOIN categories USING (categorycode)
1284 $query.= 'WHERE branchcode=? AND dateexpiry BETWEEN ? AND ?';
1286 $query.= 'WHERE dateexpiry BETWEEN ? AND ?';
1289 my $sth = $dbh->prepare( $query );
1290 my @pars = $branch? ( $branch ): ();
1291 push @pars, $date1, $date2;
1292 $sth->execute( @pars );
1293 my $results = $sth->fetchall_arrayref( {} );
1297 =head2 GetBorrowerCategorycode
1299 $categorycode = &GetBorrowerCategoryCode( $borrowernumber );
1301 Given the borrowernumber, the function returns the corresponding categorycode
1305 sub GetBorrowerCategorycode {
1306 my ( $borrowernumber ) = @_;
1307 my $dbh = C4::Context->dbh;
1308 my $sth = $dbh->prepare( qq{
1311 WHERE borrowernumber = ?
1313 $sth->execute( $borrowernumber );
1314 return $sth->fetchrow;
1319 $dateofbirth,$date = &GetAge($date);
1321 this function return the borrowers age with the value of dateofbirth
1327 my ( $date, $date_ref ) = @_;
1329 if ( not defined $date_ref ) {
1330 $date_ref = sprintf( '%04d-%02d-%02d', Today() );
1333 my ( $year1, $month1, $day1 ) = split /-/, $date;
1334 my ( $year2, $month2, $day2 ) = split /-/, $date_ref;
1336 my $age = $year2 - $year1;
1337 if ( $month1 . $day1 > $month2 . $day2 ) {
1346 $borrower = C4::Members::SetAge($borrower, $datetimeduration);
1347 $borrower = C4::Members::SetAge($borrower, '0015-12-10');
1348 $borrower = C4::Members::SetAge($borrower, $datetimeduration, $datetime_reference);
1350 eval { $borrower = C4::Members::SetAge($borrower, '015-1-10'); };
1351 if ($@) {print $@;} #Catch a bad ISO Date or kill your script!
1353 This function sets the borrower's dateofbirth to match the given age.
1354 Optionally relative to the given $datetime_reference.
1356 @PARAM1 koha.borrowers-object
1357 @PARAM2 DateTime::Duration-object as the desired age
1358 OR a ISO 8601 Date. (To make the API more pleasant)
1359 @PARAM3 DateTime-object as the relative date, defaults to now().
1360 RETURNS The given borrower reference @PARAM1.
1361 DIES If there was an error with the ISO Date handling.
1367 my ( $borrower, $datetimeduration, $datetime_ref ) = @_;
1368 $datetime_ref = DateTime->now() unless $datetime_ref;
1370 if ($datetimeduration && ref $datetimeduration ne 'DateTime::Duration') {
1371 if ($datetimeduration =~ /^(\d{4})-(\d{2})-(\d{2})/) {
1372 $datetimeduration = DateTime::Duration->new(years => $1, months => $2, days => $3);
1375 die "C4::Members::SetAge($borrower, $datetimeduration), datetimeduration not a valid ISO 8601 Date!\n";
1379 my $new_datetime_ref = $datetime_ref->clone();
1380 $new_datetime_ref->subtract_duration( $datetimeduration );
1382 $borrower->{dateofbirth} = $new_datetime_ref->ymd();
1387 =head2 GetSortDetails (OUEST-PROVENCE)
1389 ($lib) = &GetSortDetails($category,$sortvalue);
1391 Returns the authorized value details
1392 C<&$lib>return value of authorized value details
1393 C<&$sortvalue>this is the value of authorized value
1394 C<&$category>this is the value of authorized value category
1398 sub GetSortDetails {
1399 my ( $category, $sortvalue ) = @_;
1400 my $dbh = C4::Context->dbh;
1401 my $query = qq|SELECT lib
1402 FROM authorised_values
1404 AND authorised_value=? |;
1405 my $sth = $dbh->prepare($query);
1406 $sth->execute( $category, $sortvalue );
1407 my $lib = $sth->fetchrow;
1408 return ($lib) if ($lib);
1409 return ($sortvalue) unless ($lib);
1412 =head2 MoveMemberToDeleted
1414 $result = &MoveMemberToDeleted($borrowernumber);
1416 Copy the record from borrowers to deletedborrowers table.
1417 The routine returns 1 for success, undef for failure.
1421 sub MoveMemberToDeleted {
1422 my ($member) = shift or return;
1424 my $schema = Koha::Database->new()->schema();
1425 my $borrowers_rs = $schema->resultset('Borrower');
1426 $borrowers_rs->result_class('DBIx::Class::ResultClass::HashRefInflator');
1427 my $borrower = $borrowers_rs->find($member);
1428 return unless $borrower;
1430 my $deleted = $schema->resultset('Deletedborrower')->create($borrower);
1432 return $deleted ? 1 : undef;
1437 DelMember($borrowernumber);
1439 This function remove directly a borrower whitout writing it on deleteborrower.
1440 + Deletes reserves for the borrower
1445 my $dbh = C4::Context->dbh;
1446 my $borrowernumber = shift;
1447 #warn "in delmember with $borrowernumber";
1448 return unless $borrowernumber; # borrowernumber is mandatory.
1449 # Delete Patron's holds
1450 my @holds = Koha::Holds->search({ borrowernumber => $borrowernumber });
1451 $_->delete for @holds;
1456 WHERE borrowernumber = ?
1458 my $sth = $dbh->prepare($query);
1459 $sth->execute($borrowernumber);
1460 logaction("MEMBERS", "DELETE", $borrowernumber, "") if C4::Context->preference("BorrowersLog");
1464 =head2 HandleDelBorrower
1466 HandleDelBorrower($borrower);
1468 When a member is deleted (DelMember in Members.pm), you should call me first.
1469 This routine deletes/moves lists and entries for the deleted member/borrower.
1470 Lists owned by the borrower are deleted, but entries from the borrower to
1471 other lists are kept.
1475 sub HandleDelBorrower {
1478 my $dbh = C4::Context->dbh;
1480 #Delete all lists and all shares of this borrower
1481 #Consistent with the approach Koha uses on deleting individual lists
1482 #Note that entries in virtualshelfcontents added by this borrower to
1483 #lists of others will be handled by a table constraint: the borrower
1484 #is set to NULL in those entries.
1485 $query="DELETE FROM virtualshelves WHERE owner=?";
1486 $dbh->do($query,undef,($borrower));
1489 #We could handle the above deletes via a constraint too.
1490 #But a new BZ report 11889 has been opened to discuss another approach.
1491 #Instead of deleting we could also disown lists (based on a pref).
1492 #In that way we could save shared and public lists.
1493 #The current table constraints support that idea now.
1494 #This pref should then govern the results of other routines/methods such as
1495 #Koha::Virtualshelf->new->delete too.
1498 =head2 ExtendMemberSubscriptionTo (OUEST-PROVENCE)
1500 $date = ExtendMemberSubscriptionTo($borrowerid, $date);
1502 Extending the subscription to a given date or to the expiry date calculated on ISO date.
1507 sub ExtendMemberSubscriptionTo {
1508 my ( $borrowerid,$date) = @_;
1509 my $dbh = C4::Context->dbh;
1510 my $borrower = GetMember('borrowernumber'=>$borrowerid);
1512 $date = (C4::Context->preference('BorrowerRenewalPeriodBase') eq 'dateexpiry') ?
1513 eval { output_pref( { dt => dt_from_string( $borrower->{'dateexpiry'} ), dateonly => 1, dateformat => 'iso' } ); }
1515 output_pref( { dt => dt_from_string, dateonly => 1, dateformat => 'iso' } );
1516 $date = GetExpiryDate( $borrower->{'categorycode'}, $date );
1518 my $sth = $dbh->do(<<EOF);
1520 SET dateexpiry='$date'
1521 WHERE borrowernumber='$borrowerid'
1524 AddEnrolmentFeeIfNeeded
( $borrower->{categorycode
}, $borrower->{borrowernumber
} );
1526 logaction
("MEMBERS", "RENEW", $borrower->{'borrowernumber'}, "Membership renewed")if C4
::Context
->preference("BorrowersLog");
1527 return $date if ($sth);
1531 =head2 GetHideLostItemsPreference
1533 $hidelostitemspref = &GetHideLostItemsPreference($borrowernumber);
1535 Returns the HideLostItems preference for the patron category of the supplied borrowernumber
1536 C<&$hidelostitemspref>return value of function, 0 or 1
1540 sub GetHideLostItemsPreference
{
1541 my ($borrowernumber) = @_;
1542 my $dbh = C4
::Context
->dbh;
1543 my $query = "SELECT hidelostitems FROM borrowers,categories WHERE borrowers.categorycode = categories.categorycode AND borrowernumber = ?";
1544 my $sth = $dbh->prepare($query);
1545 $sth->execute($borrowernumber);
1546 my $hidelostitems = $sth->fetchrow;
1547 return $hidelostitems;
1550 =head2 GetBorrowersToExpunge
1552 $borrowers = &GetBorrowersToExpunge(
1553 not_borrowed_since => $not_borrowed_since,
1554 expired_before => $expired_before,
1555 category_code => $category_code,
1556 patron_list_id => $patron_list_id,
1557 branchcode => $branchcode
1560 This function get all borrowers based on the given criteria.
1564 sub GetBorrowersToExpunge
{
1567 my $filterdate = $params->{'not_borrowed_since'};
1568 my $filterexpiry = $params->{'expired_before'};
1569 my $filtercategory = $params->{'category_code'};
1570 my $filterbranch = $params->{'branchcode'} ||
1571 ((C4
::Context
->preference('IndependentBranches')
1572 && C4
::Context
->userenv
1573 && !C4
::Context
->IsSuperLibrarian()
1574 && C4
::Context
->userenv->{branch
})
1575 ? C4
::Context
->userenv->{branch
}
1577 my $filterpatronlist = $params->{'patron_list_id'};
1579 my $dbh = C4
::Context
->dbh;
1581 SELECT borrowers
.borrowernumber
,
1582 MAX
(old_issues
.timestamp
) AS latestissue
,
1583 MAX
(issues
.timestamp
) AS currentissue
1585 JOIN categories USING
(categorycode
)
1589 WHERE guarantorid IS NOT NULL
1590 AND guarantorid
<> 0
1591 ) as tmp ON borrowers
.borrowernumber
=tmp
.guarantorid
1592 LEFT JOIN old_issues USING
(borrowernumber
)
1593 LEFT JOIN issues USING
(borrowernumber
)|;
1594 if ( $filterpatronlist ){
1595 $query .= q
| LEFT JOIN patron_list_patrons USING
(borrowernumber
)|;
1597 $query .= q
| WHERE category_type
<> 'S'
1598 AND tmp
.guarantorid IS NULL
1601 if ( $filterbranch && $filterbranch ne "" ) {
1602 $query.= " AND borrowers.branchcode = ? ";
1603 push( @query_params, $filterbranch );
1605 if ( $filterexpiry ) {
1606 $query .= " AND dateexpiry < ? ";
1607 push( @query_params, $filterexpiry );
1609 if ( $filtercategory ) {
1610 $query .= " AND categorycode = ? ";
1611 push( @query_params, $filtercategory );
1613 if ( $filterpatronlist ){
1614 $query.=" AND patron_list_id = ? ";
1615 push( @query_params, $filterpatronlist );
1617 $query.=" GROUP BY borrowers.borrowernumber HAVING currentissue IS NULL ";
1618 if ( $filterdate ) {
1619 $query.=" AND ( latestissue < ? OR latestissue IS NULL ) ";
1620 push @query_params,$filterdate;
1622 warn $query if $debug;
1624 my $sth = $dbh->prepare($query);
1625 if (scalar(@query_params)>0){
1626 $sth->execute(@query_params);
1633 while ( my $data = $sth->fetchrow_hashref ) {
1634 push @results, $data;
1639 =head2 GetBorrowersWhoHaveNeverBorrowed
1641 $results = &GetBorrowersWhoHaveNeverBorrowed
1643 This function get all borrowers who have never borrowed.
1645 I<$result> is a ref to an array which all elements are a hasref.
1649 sub GetBorrowersWhoHaveNeverBorrowed
{
1650 my $filterbranch = shift ||
1651 ((C4
::Context
->preference('IndependentBranches')
1652 && C4
::Context
->userenv
1653 && !C4
::Context
->IsSuperLibrarian()
1654 && C4
::Context
->userenv->{branch
})
1655 ? C4
::Context
->userenv->{branch
}
1657 my $dbh = C4
::Context
->dbh;
1659 SELECT borrowers.borrowernumber,max(timestamp) as latestissue
1661 LEFT JOIN issues ON borrowers.borrowernumber = issues.borrowernumber
1662 WHERE issues.borrowernumber IS NULL
1665 if ($filterbranch && $filterbranch ne ""){
1666 $query.=" AND borrowers.branchcode= ?";
1667 push @query_params,$filterbranch;
1669 warn $query if $debug;
1671 my $sth = $dbh->prepare($query);
1672 if (scalar(@query_params)>0){
1673 $sth->execute(@query_params);
1680 while ( my $data = $sth->fetchrow_hashref ) {
1681 push @results, $data;
1686 =head2 GetBorrowersWithIssuesHistoryOlderThan
1688 $results = &GetBorrowersWithIssuesHistoryOlderThan($date)
1690 this function get all borrowers who has an issue history older than I<$date> given on input arg.
1692 I<$result> is a ref to an array which all elements are a hashref.
1693 This hashref is containt the number of time this borrowers has borrowed before I<$date> and the borrowernumber.
1697 sub GetBorrowersWithIssuesHistoryOlderThan
{
1698 my $dbh = C4
::Context
->dbh;
1699 my $date = shift ||POSIX
::strftime
("%Y-%m-%d",localtime());
1700 my $filterbranch = shift ||
1701 ((C4
::Context
->preference('IndependentBranches')
1702 && C4
::Context
->userenv
1703 && !C4
::Context
->IsSuperLibrarian()
1704 && C4
::Context
->userenv->{branch
})
1705 ? C4
::Context
->userenv->{branch
}
1708 SELECT count(borrowernumber) as n,borrowernumber
1710 WHERE returndate < ?
1711 AND borrowernumber IS NOT NULL
1714 push @query_params, $date;
1716 $query.=" AND branchcode = ?";
1717 push @query_params, $filterbranch;
1719 $query.=" GROUP BY borrowernumber ";
1720 warn $query if $debug;
1721 my $sth = $dbh->prepare($query);
1722 $sth->execute(@query_params);
1725 while ( my $data = $sth->fetchrow_hashref ) {
1726 push @results, $data;
1733 IssueSlip($branchcode, $borrowernumber, $quickslip)
1735 Returns letter hash ( see C4::Letters::GetPreparedLetter )
1737 $quickslip is boolean, to indicate whether we want a quick slip
1739 IssueSlip populates ISSUESLIP and ISSUEQSLIP, and will make the following expansions:
1775 NOTE: Not all table fields are available, pleasee see GetPendingIssues for a list of available fields.
1780 my ($branch, $borrowernumber, $quickslip) = @_;
1782 # FIXME Check callers before removing this statement
1783 #return unless $borrowernumber;
1785 my @issues = @
{ GetPendingIssues
($borrowernumber) };
1787 for my $issue (@issues) {
1788 $issue->{date_due
} = $issue->{date_due_sql
};
1790 my $today = output_pref
({ dt
=> dt_from_string
, dateformat
=> 'iso', dateonly
=> 1 });
1791 if ( substr( $issue->{issuedate
}, 0, 10 ) eq $today
1792 or substr( $issue->{lastreneweddate
}, 0, 10 ) eq $today ) {
1798 # Sort on timestamp then on issuedate (useful for tests and could be if modified in a batch
1800 my $s = $b->{timestamp
} <=> $a->{timestamp
};
1802 $b->{issuedate
} <=> $a->{issuedate
} : $s;
1805 my ($letter_code, %repeat);
1807 $letter_code = 'ISSUEQSLIP';
1809 'checkedout' => [ map {
1812 'biblioitems' => $_,
1814 }, grep { $_->{'now'} } @issues ],
1818 $letter_code = 'ISSUESLIP';
1820 'checkedout' => [ map {
1823 'biblioitems' => $_,
1825 }, grep { !$_->{'overdue'} } @issues ],
1827 'overdue' => [ map {
1830 'biblioitems' => $_,
1832 }, grep { $_->{'overdue'} } @issues ],
1835 $_->{'timestamp'} = $_->{'newdate'};
1837 } @
{ GetNewsToDisplay
("slip",$branch) } ],
1841 return C4
::Letters
::GetPreparedLetter
(
1842 module
=> 'circulation',
1843 letter_code
=> $letter_code,
1844 branchcode
=> $branch,
1846 'branches' => $branch,
1847 'borrowers' => $borrowernumber,
1853 =head2 GetBorrowersWithEmail
1855 ([$borrnum,$userid], ...) = GetBorrowersWithEmail('me@example.com');
1857 This gets a list of users and their basic details from their email address.
1858 As it's possible for multiple user to have the same email address, it provides
1859 you with all of them. If there is no userid for the user, there will be an
1860 C<undef> there. An empty list will be returned if there are no matches.
1864 sub GetBorrowersWithEmail
{
1867 my $dbh = C4
::Context
->dbh;
1869 my $query = "SELECT borrowernumber, userid FROM borrowers WHERE email=?";
1870 my $sth=$dbh->prepare($query);
1871 $sth->execute($email);
1873 while (my $ref = $sth->fetch) {
1876 die "Failure searching for borrowers by email address: $sth->errstr" if $sth->err;
1880 =head2 AddMember_Opac
1884 sub AddMember_Opac
{
1885 my ( %borrower ) = @_;
1887 $borrower{'categorycode'} //= C4
::Context
->preference('PatronSelfRegistrationDefaultCategory');
1888 if (not defined $borrower{'password'}){
1889 my $sr = new String
::Random
;
1890 $sr->{'A'} = [ 'A'..'Z', 'a'..'z' ];
1891 my $password = $sr->randpattern("AAAAAAAAAA");
1892 $borrower{'password'} = $password;
1895 $borrower{'cardnumber'} = fixup_cardnumber
( $borrower{'cardnumber'} );
1897 my $borrowernumber = AddMember
(%borrower);
1899 return ( $borrowernumber, $borrower{'password'} );
1902 =head2 AddEnrolmentFeeIfNeeded
1904 AddEnrolmentFeeIfNeeded( $borrower->{categorycode}, $borrower->{borrowernumber} );
1906 Add enrolment fee for a patron if needed.
1910 sub AddEnrolmentFeeIfNeeded
{
1911 my ( $categorycode, $borrowernumber ) = @_;
1912 # check for enrollment fee & add it if needed
1913 my $dbh = C4
::Context
->dbh;
1914 my $sth = $dbh->prepare(q{
1917 WHERE categorycode=?
1919 $sth->execute( $categorycode );
1921 warn sprintf('Database returned the following error: %s', $sth->errstr);
1924 my ($enrolmentfee) = $sth->fetchrow;
1925 if ($enrolmentfee && $enrolmentfee > 0) {
1926 # insert fee in patron debts
1927 C4
::Accounts
::manualinvoice
( $borrowernumber, '', '', 'A', $enrolmentfee );
1936 my ( $borrowernumber ) = @_;
1938 my $sql = "SELECT COUNT(*) FROM issues WHERE date_due < NOW() AND borrowernumber = ?";
1939 my $sth = C4
::Context
->dbh->prepare( $sql );
1940 $sth->execute( $borrowernumber );
1941 my ( $count ) = $sth->fetchrow_array();
1946 =head2 DeleteExpiredOpacRegistrations
1948 Delete accounts that haven't been upgraded from the 'temporary' category
1949 Returns the number of removed patrons
1953 sub DeleteExpiredOpacRegistrations
{
1955 my $delay = C4
::Context
->preference('PatronSelfRegistrationExpireTemporaryAccountsDelay');
1956 my $category_code = C4
::Context
->preference('PatronSelfRegistrationDefaultCategory');
1958 return 0 if not $category_code or not defined $delay or $delay eq q
||;
1961 SELECT borrowernumber
1963 WHERE categorycode
= ? AND DATEDIFF
( NOW
(), dateenrolled
) > ?
|;
1965 my $dbh = C4
::Context
->dbh;
1966 my $sth = $dbh->prepare($query);
1967 $sth->execute( $category_code, $delay );
1969 while ( my ($borrowernumber) = $sth->fetchrow_array() ) {
1970 DelMember
($borrowernumber);
1976 =head2 DeleteUnverifiedOpacRegistrations
1978 Delete all unverified self registrations in borrower_modifications,
1979 older than the specified number of days.
1983 sub DeleteUnverifiedOpacRegistrations
{
1985 my $dbh = C4
::Context
->dbh;
1987 DELETE FROM borrower_modifications
1988 WHERE borrowernumber
= 0 AND DATEDIFF
( NOW
(), timestamp
) > ?
|;
1989 my $cnt=$dbh->do($sql, undef, ($days) );
1990 return $cnt eq '0E0'?
0: $cnt;
1993 sub GetOverduesForPatron
{
1994 my ( $borrowernumber ) = @_;
1998 FROM issues, items, biblio, biblioitems
1999 WHERE items.itemnumber=issues.itemnumber
2000 AND biblio.biblionumber = items.biblionumber
2001 AND biblio.biblionumber = biblioitems.biblionumber
2002 AND issues.borrowernumber = ?
2003 AND date_due < NOW()
2006 my $sth = C4
::Context
->dbh->prepare( $sql );
2007 $sth->execute( $borrowernumber );
2009 return $sth->fetchall_arrayref({});
2012 END { } # module clean-up code here (global destructor)