3 # Copyright 2000-2003 Katipo Communications
4 # Copyright 2010 BibLibre
5 # Parts Copyright 2010 Catalyst IT
7 # This file is part of Koha.
9 # Koha is free software; you can redistribute it and/or modify it
10 # under the terms of the GNU General Public License as published by
11 # the Free Software Foundation; either version 3 of the License, or
12 # (at your option) any later version.
14 # Koha is distributed in the hope that it will be useful, but
15 # WITHOUT ANY WARRANTY; without even the implied warranty of
16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 # GNU General Public License for more details.
19 # You should have received a copy of the GNU General Public License
20 # along with Koha; if not, see <http://www.gnu.org/licenses>.
24 #use warnings; FIXME - Bug 2505
26 use String
::Random
qw( random_string );
27 use Scalar
::Util
qw( looks_like_number );
28 use Date
::Calc qw
/Today Add_Delta_YM check_date Date_to_Days/;
29 use C4
::Log
; # logaction
35 use C4
::Members
::Attributes
qw(SearchIdMatchingAttribute UpdateBorrowerAttribute);
36 use C4
::NewsChannels
; #get slip news
40 use Text
::Unaccent
qw( unac_string );
41 use Koha
::AuthUtils
qw(hash_password);
44 use Koha
::List
::Patron
;
47 our (@ISA,@EXPORT,@EXPORT_OK,$debug);
49 use Module
::Load
::Conditional
qw( can_load );
50 if ( ! can_load
( modules
=> { 'Koha::NorwegianPatronDB' => undef } ) ) {
51 $debug && warn "Unable to load Koha::NorwegianPatronDB";
56 $debug = $ENV{DEBUG
} || 0;
65 &GetMemberIssuesAndFines
69 &GetFirstValidEmailAddress
70 &GetNoticeEmailAddress
76 &GetHideLostItemsPreference
79 &GetMemberAccountRecords
80 &GetBorNotifyAcctRecord
84 GetBorrowerCategorycode
85 &GetBorrowercategoryList
87 &GetBorrowersToExpunge
88 &GetBorrowersWhoHaveNeverBorrowed
89 &GetBorrowersWithIssuesHistoryOlderThan
92 &GetUpcomingMembershipExpires
117 &ExtendMemberSubscriptionTo
133 C4::Members - Perl Module containing convenience functions for member handling
141 This module contains routines for adding, modifying and deleting members/patrons/borrowers
145 =head2 GetMemberDetails
147 ($borrower) = &GetMemberDetails($borrowernumber, $cardnumber);
149 Looks up a patron and returns information about him or her. If
150 C<$borrowernumber> is true (nonzero), C<&GetMemberDetails> looks
151 up the borrower by number; otherwise, it looks up the borrower by card
154 C<$borrower> is a reference-to-hash whose keys are the fields of the
155 borrowers table in the Koha database. In addition,
156 C<$borrower-E<gt>{flags}> is a hash giving more detailed information
157 about the patron. Its keys act as flags :
159 if $borrower->{flags}->{LOST} {
160 # Patron's card was reported lost
163 If the state of a flag means that the patron should not be
164 allowed to borrow any more books, then it will have a C<noissues> key
167 See patronflags for more details.
169 C<$borrower-E<gt>{authflags}> is a hash giving more detailed information
170 about the top-level permissions flags set for the borrower. For example,
171 if a user has the "editcatalogue" permission,
172 C<$borrower-E<gt>{authflags}-E<gt>{editcatalogue}> will exist and have
177 sub GetMemberDetails
{
178 my ( $borrowernumber, $cardnumber ) = @_;
179 my $dbh = C4
::Context
->dbh;
182 if ($borrowernumber) {
183 $sth = $dbh->prepare("
186 categories.description,
187 categories.BlockExpiredPatronOpacActions,
191 LEFT JOIN categories ON borrowers.categorycode=categories.categorycode
192 WHERE borrowernumber = ?
194 $sth->execute($borrowernumber);
196 elsif ($cardnumber) {
197 $sth = $dbh->prepare("
200 categories.description,
201 categories.BlockExpiredPatronOpacActions,
205 LEFT JOIN categories ON borrowers.categorycode = categories.categorycode
208 $sth->execute($cardnumber);
213 my $borrower = $sth->fetchrow_hashref;
214 return unless $borrower;
215 my ($amount) = GetMemberAccountRecords
($borrower->{borrowernumber
});
216 $borrower->{'amountoutstanding'} = $amount;
217 # FIXME - patronflags calls GetMemberAccountRecords... just have patronflags return $amount
218 my $flags = patronflags
( $borrower);
221 $sth = $dbh->prepare("select bit,flag from userflags");
223 while ( my ( $bit, $flag ) = $sth->fetchrow ) {
224 if ( $borrower->{'flags'} && $borrower->{'flags'} & 2**$bit ) {
225 $accessflagshash->{$flag} = 1;
228 $borrower->{'flags'} = $flags;
229 $borrower->{'authflags'} = $accessflagshash;
231 # Handle setting the true behavior for BlockExpiredPatronOpacActions
232 $borrower->{'BlockExpiredPatronOpacActions'} =
233 C4
::Context
->preference('BlockExpiredPatronOpacActions')
234 if ( $borrower->{'BlockExpiredPatronOpacActions'} == -1 );
236 $borrower->{'is_expired'} = 0;
237 $borrower->{'is_expired'} = 1 if
238 defined($borrower->{dateexpiry
}) &&
239 $borrower->{'dateexpiry'} ne '0000-00-00' &&
240 Date_to_Days
( Today
() ) >
241 Date_to_Days
( split /-/, $borrower->{'dateexpiry'} );
243 return ($borrower); #, $flags, $accessflagshash);
248 $flags = &patronflags($patron);
250 This function is not exported.
252 The following will be set where applicable:
253 $flags->{CHARGES}->{amount} Amount of debt
254 $flags->{CHARGES}->{noissues} Set if debt amount >$5.00 (or syspref noissuescharge)
255 $flags->{CHARGES}->{message} Message -- deprecated
257 $flags->{CREDITS}->{amount} Amount of credit
258 $flags->{CREDITS}->{message} Message -- deprecated
260 $flags->{ GNA } Patron has no valid address
261 $flags->{ GNA }->{noissues} Set for each GNA
262 $flags->{ GNA }->{message} "Borrower has no valid address" -- deprecated
264 $flags->{ LOST } Patron's card reported lost
265 $flags->{ LOST }->{noissues} Set for each LOST
266 $flags->{ LOST }->{message} Message -- deprecated
268 $flags->{DBARRED} Set if patron debarred, no access
269 $flags->{DBARRED}->{noissues} Set for each DBARRED
270 $flags->{DBARRED}->{message} Message -- deprecated
273 $flags->{ NOTES }->{message} The note itself. NOT deprecated
275 $flags->{ ODUES } Set if patron has overdue books.
276 $flags->{ ODUES }->{message} "Yes" -- deprecated
277 $flags->{ ODUES }->{itemlist} ref-to-array: list of overdue books
278 $flags->{ ODUES }->{itemlisttext} Text list of overdue items -- deprecated
280 $flags->{WAITING} Set if any of patron's reserves are available
281 $flags->{WAITING}->{message} Message -- deprecated
282 $flags->{WAITING}->{itemlist} ref-to-array: list of available items
286 =item C<$flags-E<gt>{ODUES}-E<gt>{itemlist}> is a reference-to-array listing the
287 overdue items. Its elements are references-to-hash, each describing an
288 overdue item. The keys are selected fields from the issues, biblio,
289 biblioitems, and items tables of the Koha database.
291 =item C<$flags-E<gt>{ODUES}-E<gt>{itemlisttext}> is a string giving a text listing of
292 the overdue items, one per line. Deprecated.
294 =item C<$flags-E<gt>{WAITING}-E<gt>{itemlist}> is a reference-to-array listing the
295 available items. Each element is a reference-to-hash whose keys are
296 fields from the reserves table of the Koha database.
300 All the "message" fields that include language generated in this function are deprecated,
301 because such strings belong properly in the display layer.
303 The "message" field that comes from the DB is OK.
307 # TODO: use {anonymous => hashes} instead of a dozen %flaginfo
308 # FIXME rename this function.
311 my ( $patroninformation) = @_;
312 my $dbh=C4
::Context
->dbh;
313 my ($balance, $owing) = GetMemberAccountBalance
( $patroninformation->{'borrowernumber'});
316 my $noissuescharge = C4
::Context
->preference("noissuescharge") || 5;
317 $flaginfo{'message'} = sprintf 'Patron owes %.02f', $owing;
318 $flaginfo{'amount'} = sprintf "%.02f", $owing;
319 if ( $owing > $noissuescharge && !C4
::Context
->preference("AllowFineOverride") ) {
320 $flaginfo{'noissues'} = 1;
322 $flags{'CHARGES'} = \
%flaginfo;
324 elsif ( $balance < 0 ) {
326 $flaginfo{'message'} = sprintf 'Patron has credit of %.02f', -$balance;
327 $flaginfo{'amount'} = sprintf "%.02f", $balance;
328 $flags{'CREDITS'} = \
%flaginfo;
331 # Check the debt of the guarntees of this patron
332 my $no_issues_charge_guarantees = C4
::Context
->preference("NoIssuesChargeGuarantees");
333 $no_issues_charge_guarantees = undef unless looks_like_number
( $no_issues_charge_guarantees );
334 if ( defined $no_issues_charge_guarantees ) {
335 my $p = Koha
::Patrons
->find( $patroninformation->{borrowernumber
} );
336 my @guarantees = $p->guarantees();
337 my $guarantees_non_issues_charges;
338 foreach my $g ( @guarantees ) {
339 my ( $b, $n, $o ) = C4
::Members
::GetMemberAccountBalance
( $g->id );
340 $guarantees_non_issues_charges += $n;
343 if ( $guarantees_non_issues_charges > $no_issues_charge_guarantees ) {
345 $flaginfo{'message'} = sprintf 'patron guarantees owe %.02f', $guarantees_non_issues_charges;
346 $flaginfo{'amount'} = $guarantees_non_issues_charges;
347 $flaginfo{'noissues'} = 1 unless C4
::Context
->preference("allowfineoverride");
348 $flags{'CHARGES_GUARANTEES'} = \
%flaginfo;
352 if ( $patroninformation->{'gonenoaddress'}
353 && $patroninformation->{'gonenoaddress'} == 1 )
356 $flaginfo{'message'} = 'Borrower has no valid address.';
357 $flaginfo{'noissues'} = 1;
358 $flags{'GNA'} = \
%flaginfo;
360 if ( $patroninformation->{'lost'} && $patroninformation->{'lost'} == 1 ) {
362 $flaginfo{'message'} = 'Borrower\'s card reported lost.';
363 $flaginfo{'noissues'} = 1;
364 $flags{'LOST'} = \
%flaginfo;
366 if ( $patroninformation->{'debarred'} && check_date
( split( /-/, $patroninformation->{'debarred'} ) ) ) {
367 if ( Date_to_Days
(Date
::Calc
::Today
) < Date_to_Days
( split( /-/, $patroninformation->{'debarred'} ) ) ) {
369 $flaginfo{'debarredcomment'} = $patroninformation->{'debarredcomment'};
370 $flaginfo{'message'} = $patroninformation->{'debarredcomment'};
371 $flaginfo{'noissues'} = 1;
372 $flaginfo{'dateend'} = $patroninformation->{'debarred'};
373 $flags{'DBARRED'} = \
%flaginfo;
376 if ( $patroninformation->{'borrowernotes'}
377 && $patroninformation->{'borrowernotes'} )
380 $flaginfo{'message'} = $patroninformation->{'borrowernotes'};
381 $flags{'NOTES'} = \
%flaginfo;
383 my ( $odues, $itemsoverdue ) = C4
::Overdues
::checkoverdues
($patroninformation->{'borrowernumber'});
384 if ( $odues && $odues > 0 ) {
386 $flaginfo{'message'} = "Yes";
387 $flaginfo{'itemlist'} = $itemsoverdue;
388 foreach ( sort { $a->{'date_due'} cmp $b->{'date_due'} }
391 $flaginfo{'itemlisttext'} .=
392 "$_->{'date_due'} $_->{'barcode'} $_->{'title'} \n"; # newline is display layer
394 $flags{'ODUES'} = \
%flaginfo;
396 my @itemswaiting = C4
::Reserves
::GetReservesFromBorrowernumber
( $patroninformation->{'borrowernumber'},'W' );
397 my $nowaiting = scalar @itemswaiting;
398 if ( $nowaiting > 0 ) {
400 $flaginfo{'message'} = "Reserved items available";
401 $flaginfo{'itemlist'} = \
@itemswaiting;
402 $flags{'WAITING'} = \
%flaginfo;
410 $borrower = &GetMember(%information);
412 Retrieve the first patron record meeting on criteria listed in the
413 C<%information> hash, which should contain one or more
414 pairs of borrowers column names and values, e.g.,
416 $borrower = GetMember(borrowernumber => id);
418 C<&GetBorrower> returns a reference-to-hash whose keys are the fields of
419 the C<borrowers> table in the Koha database.
421 FIXME: GetMember() is used throughout the code as a lookup
422 on a unique key such as the borrowernumber, but this meaning is not
423 enforced in the routine itself.
429 my ( %information ) = @_;
430 if (exists $information{borrowernumber
} && !defined $information{borrowernumber
}) {
431 #passing mysql's kohaadmin?? Makes no sense as a query
434 my $dbh = C4
::Context
->dbh;
436 q{SELECT borrowers.*, categories.category_type, categories.description
438 LEFT JOIN categories on borrowers.categorycode=categories.categorycode WHERE };
441 for (keys %information ) {
449 if (defined $information{$_}) {
451 push @values, $information{$_};
454 $select .= "$_ IS NULL";
457 $debug && warn $select, " ",values %information;
458 my $sth = $dbh->prepare("$select");
459 $sth->execute(@values);
460 my $data = $sth->fetchall_arrayref({});
461 #FIXME interface to this routine now allows generation of a result set
462 #so whole array should be returned but bowhere in the current code expects this
470 =head2 IsMemberBlocked
472 my ($block_status, $count) = IsMemberBlocked( $borrowernumber );
474 Returns whether a patron is restricted or has overdue items that may result
475 in a block of circulation privileges.
477 C<$block_status> can have the following values:
479 1 if the patron is currently restricted, in which case
480 C<$count> is the expiration date (9999-12-31 for indefinite)
482 -1 if the patron has overdue items, in which case C<$count> is the number of them
484 0 if the patron has no overdue items or outstanding fine days, in which case C<$count> is 0
486 Existing active restrictions are checked before current overdue items.
490 sub IsMemberBlocked
{
491 my $borrowernumber = shift;
492 my $dbh = C4
::Context
->dbh;
494 my $blockeddate = Koha
::Patrons
->find( $borrowernumber )->is_debarred;
496 return ( 1, $blockeddate ) if $blockeddate;
498 # if he have late issues
499 my $sth = $dbh->prepare(
500 "SELECT COUNT(*) as latedocs
502 WHERE borrowernumber = ?
503 AND date_due < now()"
505 $sth->execute($borrowernumber);
506 my $latedocs = $sth->fetchrow_hashref->{'latedocs'};
508 return ( -1, $latedocs ) if $latedocs > 0;
513 =head2 GetMemberIssuesAndFines
515 ($overdue_count, $issue_count, $total_fines) = &GetMemberIssuesAndFines($borrowernumber);
517 Returns aggregate data about items borrowed by the patron with the
518 given borrowernumber.
520 C<&GetMemberIssuesAndFines> returns a three-element array. C<$overdue_count> is the
521 number of overdue items the patron currently has borrowed. C<$issue_count> is the
522 number of books the patron currently has borrowed. C<$total_fines> is
523 the total fine currently due by the borrower.
528 sub GetMemberIssuesAndFines
{
529 my ( $borrowernumber ) = @_;
530 my $dbh = C4
::Context
->dbh;
531 my $query = "SELECT COUNT(*) FROM issues WHERE borrowernumber = ?";
533 $debug and warn $query."\n";
534 my $sth = $dbh->prepare($query);
535 $sth->execute($borrowernumber);
536 my $issue_count = $sth->fetchrow_arrayref->[0];
538 $sth = $dbh->prepare(
539 "SELECT COUNT(*) FROM issues
540 WHERE borrowernumber = ?
541 AND date_due < now()"
543 $sth->execute($borrowernumber);
544 my $overdue_count = $sth->fetchrow_arrayref->[0];
546 $sth = $dbh->prepare("SELECT SUM(amountoutstanding) FROM accountlines WHERE borrowernumber = ?");
547 $sth->execute($borrowernumber);
548 my $total_fines = $sth->fetchrow_arrayref->[0];
550 return ($overdue_count, $issue_count, $total_fines);
556 my @columns = C4::Member::columns();
558 Returns an array of borrowers' table columns on success,
559 and an empty array on failure.
565 # Pure ANSI SQL goodness.
566 my $sql = 'SELECT * FROM borrowers WHERE 1=0;';
568 # Get the database handle.
569 my $dbh = C4
::Context
->dbh;
571 # Run the SQL statement to load STH's readonly properties.
572 my $sth = $dbh->prepare($sql);
573 my $rv = $sth->execute();
575 # This only fails if the table doesn't exist.
576 # This will always be called AFTER an install or upgrade,
577 # so borrowers will exist!
579 if ($sth->{NUM_OF_FIELDS
}>0) {
580 @data = @
{$sth->{NAME
}};
591 my $success = ModMember(borrowernumber => $borrowernumber,
592 [ field => value ]... );
594 Modify borrower's data. All date fields should ALREADY be in ISO format.
597 true on success, or false on failure
603 # test to know if you must update or not the borrower password
604 if (exists $data{password
}) {
605 if ($data{password
} eq '****' or $data{password
} eq '') {
606 delete $data{password
};
608 if ( C4
::Context
->preference('NorwegianPatronDBEnable') && C4
::Context
->preference('NorwegianPatronDBEnable') == 1 ) {
609 # Update the hashed PIN in borrower_sync.hashed_pin, before Koha hashes it
610 Koha
::NorwegianPatronDB
::NLUpdateHashedPIN
( $data{'borrowernumber'}, $data{password
} );
612 $data{password
} = hash_password
($data{password
});
616 my $old_categorycode = GetBorrowerCategorycode
( $data{borrowernumber
} );
618 # get only the columns of a borrower
619 my $schema = Koha
::Database
->new()->schema;
620 my @columns = $schema->source('Borrower')->columns;
621 my $new_borrower = { map { join(' ', @columns) =~ /$_/ ?
( $_ => $data{$_} ) : () } keys(%data) };
622 delete $new_borrower->{flags
};
624 $new_borrower->{dateofbirth
} ||= undef if exists $new_borrower->{dateofbirth
};
625 $new_borrower->{dateenrolled
} ||= undef if exists $new_borrower->{dateenrolled
};
626 $new_borrower->{dateexpiry
} ||= undef if exists $new_borrower->{dateexpiry
};
627 $new_borrower->{debarred
} ||= undef if exists $new_borrower->{debarred
};
628 $new_borrower->{sms_provider_id
} ||= undef if exists $new_borrower->{sms_provider_id
};
630 my $rs = $schema->resultset('Borrower')->search({
631 borrowernumber
=> $new_borrower->{borrowernumber
},
634 delete $new_borrower->{userid
} if exists $new_borrower->{userid
} and not $new_borrower->{userid
};
636 my $execute_success = $rs->update($new_borrower);
637 if ($execute_success ne '0E0') { # only proceed if the update was a success
638 # If the patron changes to a category with enrollment fee, we add a fee
639 if ( $data{categorycode
} and $data{categorycode
} ne $old_categorycode ) {
640 if ( C4
::Context
->preference('FeeOnChangePatronCategory') ) {
641 AddEnrolmentFeeIfNeeded
( $data{categorycode
}, $data{borrowernumber
} );
645 # If NorwegianPatronDBEnable is enabled, we set syncstatus to something that a
646 # cronjob will use for syncing with NL
647 if ( C4
::Context
->preference('NorwegianPatronDBEnable') && C4
::Context
->preference('NorwegianPatronDBEnable') == 1 ) {
648 my $borrowersync = Koha
::Database
->new->schema->resultset('BorrowerSync')->find({
649 'synctype' => 'norwegianpatrondb',
650 'borrowernumber' => $data{'borrowernumber'}
652 # Do not set to "edited" if syncstatus is "new". We need to sync as new before
653 # we can sync as changed. And the "new sync" will pick up all changes since
654 # the patron was created anyway.
655 if ( $borrowersync->syncstatus ne 'new' && $borrowersync->syncstatus ne 'delete' ) {
656 $borrowersync->update( { 'syncstatus' => 'edited' } );
658 # Set the value of 'sync'
659 $borrowersync->update( { 'sync' => $data{'sync'} } );
660 # Try to do the live sync
661 Koha
::NorwegianPatronDB
::NLSync
({ 'borrowernumber' => $data{'borrowernumber'} });
664 logaction
("MEMBERS", "MODIFY", $data{'borrowernumber'}, "UPDATE (executed w/ arg: $data{'borrowernumber'})") if C4
::Context
->preference("BorrowersLog");
666 return $execute_success;
671 $borrowernumber = &AddMember(%borrower);
673 insert new borrower into table
675 (%borrower keys are database columns. Database columns could be
676 different in different versions. Please look into database for correct
679 Returns the borrowernumber upon success
681 Returns as undef upon any db error without further processing
688 my $dbh = C4
::Context
->dbh;
689 my $schema = Koha
::Database
->new()->schema;
691 # generate a proper login if none provided
692 $data{'userid'} = Generate_Userid
( $data{'borrowernumber'}, $data{'firstname'}, $data{'surname'} )
693 if ( $data{'userid'} eq '' || !Check_Userid
( $data{'userid'} ) );
695 # add expiration date if it isn't already there
696 unless ( $data{'dateexpiry'} ) {
697 $data{'dateexpiry'} = GetExpiryDate
( $data{'categorycode'}, output_pref
( { dt
=> dt_from_string
, dateonly
=> 1, dateformat
=> 'iso' } ) );
700 # add enrollment date if it isn't already there
701 unless ( $data{'dateenrolled'} ) {
702 $data{'dateenrolled'} = output_pref
( { dt
=> dt_from_string
, dateonly
=> 1, dateformat
=> 'iso' } );
705 my $patron_category = $schema->resultset('Category')->find( $data{'categorycode'} );
707 $patron_category->default_privacy() eq 'default' ?
1
708 : $patron_category->default_privacy() eq 'never' ?
2
709 : $patron_category->default_privacy() eq 'forever' ?
0
712 $data{'privacy_guarantor_checkouts'} = 0 unless defined( $data{'privacy_guarantor_checkouts'} );
714 # Make a copy of the plain text password for later use
715 my $plain_text_password = $data{'password'};
717 # create a disabled account if no password provided
718 $data{'password'} = ($data{'password'})? hash_password
($data{'password'}) : '!';
720 # we don't want invalid dates in the db (mysql has a bad habit of inserting 0000-00-00
721 $data{'dateofbirth'} = undef if ( not $data{'dateofbirth'} );
722 $data{'debarred'} = undef if ( not $data{'debarred'} );
723 $data{'sms_provider_id'} = undef if ( not $data{'sms_provider_id'} );
725 # get only the columns of Borrower
726 my @columns = $schema->source('Borrower')->columns;
727 my $new_member = { map { join(' ',@columns) =~ /$_/ ?
( $_ => $data{$_} ) : () } keys(%data) } ;
728 $new_member->{checkprevcheckout
} ||= 'inherit';
729 delete $new_member->{borrowernumber
};
731 my $rs = $schema->resultset('Borrower');
732 $data{borrowernumber
} = $rs->create($new_member)->id;
734 # If NorwegianPatronDBEnable is enabled, we set syncstatus to something that a
735 # cronjob will use for syncing with NL
736 if ( exists $data{'borrowernumber'} && C4
::Context
->preference('NorwegianPatronDBEnable') && C4
::Context
->preference('NorwegianPatronDBEnable') == 1 ) {
737 Koha
::Database
->new->schema->resultset('BorrowerSync')->create({
738 'borrowernumber' => $data{'borrowernumber'},
739 'synctype' => 'norwegianpatrondb',
741 'syncstatus' => 'new',
742 'hashed_pin' => Koha
::NorwegianPatronDB
::NLEncryptPIN
( $plain_text_password ),
746 # mysql_insertid is probably bad. not necessarily accurate and mysql-specific at best.
747 logaction
("MEMBERS", "CREATE", $data{'borrowernumber'}, "") if C4
::Context
->preference("BorrowersLog");
749 AddEnrolmentFeeIfNeeded
( $data{categorycode
}, $data{borrowernumber
} );
751 return $data{borrowernumber
};
756 my $uniqueness = Check_Userid($userid,$borrowernumber);
758 $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 != '').
760 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.
763 0 for not unique (i.e. this $userid already exists)
764 1 for unique (i.e. this $userid does not exist, or this $userid/$borrowernumber combination already exists)
769 my ( $uid, $borrowernumber ) = @_;
771 return 0 unless ($uid); # userid is a unique column, we should assume NULL is not unique
773 return 0 if ( $uid eq C4
::Context
->config('user') );
775 my $rs = Koha
::Database
->new()->schema()->resultset('Borrower');
778 $params->{userid
} = $uid;
779 $params->{borrowernumber
} = { '!=' => $borrowernumber } if ($borrowernumber);
781 my $count = $rs->count( $params );
783 return $count ?
0 : 1;
786 =head2 Generate_Userid
788 my $newuid = Generate_Userid($borrowernumber, $firstname, $surname);
790 Generate a userid using the $surname and the $firstname (if there is a value in $firstname).
792 $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.
795 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).
799 sub Generate_Userid
{
800 my ($borrowernumber, $firstname, $surname) = @_;
803 #The script will "do" the following code and increment the $offset until Check_Userid = 1 (i.e. until $newuid comes back as unique)
805 $firstname =~ s/[[:digit:][:space:][:blank:][:punct:][:cntrl:]]//g;
806 $surname =~ s/[[:digit:][:space:][:blank:][:punct:][:cntrl:]]//g;
807 $newuid = lc(($firstname)?
"$firstname.$surname" : $surname);
808 $newuid = unac_string
('utf-8',$newuid);
809 $newuid .= $offset unless $offset == 0;
812 } while (!Check_Userid
($newuid,$borrowernumber));
817 =head2 fixup_cardnumber
819 Warning: The caller is responsible for locking the members table in write
820 mode, to avoid database corruption.
824 use vars
qw( @weightings );
825 my @weightings = ( 8, 4, 6, 3, 5, 2, 1 );
827 sub fixup_cardnumber {
828 my ($cardnumber) = @_;
829 my $autonumber_members = C4::Context->boolean_preference('autoMemberNum') || 0;
831 # Find out whether member numbers should be generated
832 # automatically. Should be either "1" or something else.
833 # Defaults to "0", which is interpreted as "no".
835 # if ($cardnumber !~ /\S/ && $autonumber_members) {
836 ($autonumber_members) or return $cardnumber;
837 my $checkdigit = C4::Context->preference('checkdigit');
838 my $dbh = C4::Context->dbh;
839 if ( $checkdigit and $checkdigit eq 'katipo' ) {
841 # if checkdigit is selected, calculate katipo-style cardnumber.
842 # otherwise, just use the max()
843 # purpose: generate checksum'd member numbers.
844 # We'll assume we just got the max value of digits 2-8 of member #'s
845 # from the database and our job is to increment that by one,
846 # determine the 1st and 9th digits and return the full string.
847 my $sth = $dbh->prepare(
848 "select max(substring(borrowers.cardnumber,2,7)) as new_num from borrowers"
851 my $data = $sth->fetchrow_hashref;
852 $cardnumber = $data->{new_num};
853 if ( !$cardnumber ) { # If DB has no values,
854 $cardnumber = 1000000; # start at 1000000
860 for ( my $i = 0 ; $i < 8 ; $i += 1 ) {
861 # read weightings, left to right, 1 char at a time
862 my $temp1 = $weightings[$i];
864 # sequence left to right, 1 char at a time
865 my $temp2 = substr( $cardnumber, $i, 1 );
867 # mult each char 1-7 by its corresponding weighting
868 $sum += $temp1 * $temp2;
871 my $rem = ( $sum % 11 );
872 $rem = 'X' if $rem == 10;
874 return "V$cardnumber$rem";
877 my $sth = $dbh->prepare(
878 'SELECT MAX( CAST( cardnumber AS SIGNED ) ) FROM borrowers WHERE cardnumber REGEXP "^-?[0-9]+$"'
881 my ($result) = $sth->fetchrow;
884 return $cardnumber; # just here as a fallback/reminder
887 =head2 GetPendingIssues
889 my $issues = &GetPendingIssues(@borrowernumber);
891 Looks up what the patron with the given borrowernumber has borrowed.
893 C<&GetPendingIssues> returns a
894 reference-to-array where each element is a reference-to-hash; the
895 keys are the fields from the C<issues>, C<biblio>, and C<items> tables.
896 The keys include C<biblioitems> fields except marc and marcxml.
900 sub GetPendingIssues {
901 my @borrowernumbers = @_;
903 unless (@borrowernumbers ) { # return a ref_to_array
904 return \@borrowernumbers; # to not cause surprise to caller
907 # Borrowers part of the query
909 for (my $i = 0; $i < @borrowernumbers; $i++) {
910 $bquery .= ' issues.borrowernumber = ?';
911 if ($i < $#borrowernumbers ) {
916 # must avoid biblioitems.* to prevent large marc and marcxml fields from killing performance
917 # FIXME: namespace collision: each table has "timestamp" fields. Which one is "timestamp" ?
918 # FIXME: circ/ciculation.pl tries to sort by timestamp!
919 # FIXME: namespace collision: other collisions possible.
920 # FIXME: most of this data isn't really being used by callers.
927 biblioitems.itemtype,
930 biblioitems.publicationyear,
931 biblioitems.publishercode,
932 biblioitems.volumedate,
933 biblioitems.volumedesc,
938 borrowers.cardnumber,
939 issues.timestamp AS timestamp,
940 issues.renewals AS renewals,
941 issues.borrowernumber AS borrowernumber,
942 items.renewals AS totalrenewals
944 LEFT JOIN items ON items.itemnumber = issues.itemnumber
945 LEFT JOIN biblio ON items.biblionumber = biblio.biblionumber
946 LEFT JOIN biblioitems ON items.biblioitemnumber = biblioitems.biblioitemnumber
947 LEFT JOIN borrowers ON issues.borrowernumber = borrowers.borrowernumber
950 ORDER BY issues.issuedate"
953 my $sth = C4::Context->dbh->prepare($query);
954 $sth->execute(@borrowernumbers);
955 my $data = $sth->fetchall_arrayref({});
956 my $today = dt_from_string;
958 if ($_->{issuedate}) {
959 $_->{issuedate} = dt_from_string($_->{issuedate}, 'sql');
961 $_->{date_due_sql} = $_->{date_due};
962 # FIXME no need to have this value
963 $_->{date_due} or next;
964 $_->{date_due_sql} = $_->{date_due};
965 # FIXME no need to have this value
966 $_->{date_due} = dt_from_string($_->{date_due}, 'sql');
967 if ( DateTime->compare($_->{date_due}, $today) == -1 ) {
976 $issues = &GetAllIssues($borrowernumber, $sortkey, $limit);
978 Looks up what the patron with the given borrowernumber has borrowed,
979 and sorts the results.
981 C<$sortkey> is the name of a field on which to sort the results. This
982 should be the name of a field in the C<issues>, C<biblio>,
983 C<biblioitems>, or C<items> table in the Koha database.
985 C<$limit> is the maximum number of results to return.
987 C<&GetAllIssues> an arrayref, C<$issues>, of hashrefs, the keys of which
988 are the fields from the C<issues>, C<biblio>, C<biblioitems>, and
989 C<items> tables of the Koha database.
995 my ( $borrowernumber, $order, $limit ) = @_;
997 return unless $borrowernumber;
998 $order = 'date_due desc' unless $order;
1000 my $dbh = C4::Context->dbh;
1002 'SELECT *, issues.timestamp as issuestimestamp, issues.renewals AS renewals,items.renewals AS totalrenewals,items.timestamp AS itemstimestamp
1004 LEFT JOIN items on items.itemnumber=issues.itemnumber
1005 LEFT JOIN biblio ON items.biblionumber=biblio.biblionumber
1006 LEFT JOIN biblioitems ON items.biblioitemnumber=biblioitems.biblioitemnumber
1007 WHERE borrowernumber=?
1009 SELECT *, old_issues.timestamp as issuestimestamp, old_issues.renewals AS renewals,items.renewals AS totalrenewals,items.timestamp AS itemstimestamp
1011 LEFT JOIN items on items.itemnumber=old_issues.itemnumber
1012 LEFT JOIN biblio ON items.biblionumber=biblio.biblionumber
1013 LEFT JOIN biblioitems ON items.biblioitemnumber=biblioitems.biblioitemnumber
1014 WHERE borrowernumber=? AND old_issues.itemnumber IS NOT NULL
1015 order by ' . $order;
1017 $query .= " limit $limit";
1020 my $sth = $dbh->prepare($query);
1021 $sth->execute( $borrowernumber, $borrowernumber );
1022 return $sth->fetchall_arrayref( {} );
1026 =head2 GetMemberAccountRecords
1028 ($total, $acctlines, $count) = &GetMemberAccountRecords($borrowernumber);
1030 Looks up accounting data for the patron with the given borrowernumber.
1032 C<&GetMemberAccountRecords> returns a three-element array. C<$acctlines> is a
1033 reference-to-array, where each element is a reference-to-hash; the
1034 keys are the fields of the C<accountlines> table in the Koha database.
1035 C<$count> is the number of elements in C<$acctlines>. C<$total> is the
1036 total amount outstanding for all of the account lines.
1040 sub GetMemberAccountRecords {
1041 my ($borrowernumber) = @_;
1042 my $dbh = C4::Context->dbh;
1048 WHERE borrowernumber=?);
1049 $strsth.=" ORDER BY accountlines_id desc";
1050 my $sth= $dbh->prepare( $strsth );
1051 $sth->execute( $borrowernumber );
1054 while ( my $data = $sth->fetchrow_hashref ) {
1055 if ( $data->{itemnumber} ) {
1056 my $biblio = GetBiblioFromItemNumber( $data->{itemnumber} );
1057 $data->{biblionumber} = $biblio->{biblionumber};
1058 $data->{title} = $biblio->{title};
1060 $acctlines[$numlines] = $data;
1062 $total += sprintf "%.0f", 1000*$data->{amountoutstanding}; # convert float to integer to avoid round-off errors
1065 return ( $total, \@acctlines,$numlines);
1068 =head2 GetMemberAccountBalance
1070 ($total_balance, $non_issue_balance, $other_charges) = &GetMemberAccountBalance($borrowernumber);
1072 Calculates amount immediately owing by the patron - non-issue charges.
1073 Based on GetMemberAccountRecords.
1074 Charges exempt from non-issue are:
1076 * Rent (rental) if RentalsInNoissuesCharge syspref is set to false
1077 * Manual invoices if ManInvInNoissuesCharge syspref is set to false
1081 sub GetMemberAccountBalance {
1082 my ($borrowernumber) = @_;
1084 my $ACCOUNT_TYPE_LENGTH = 5; # this is plain ridiculous...
1087 push @not_fines, 'Res' unless C4::Context->preference('HoldsInNoissuesCharge');
1088 push @not_fines, 'Rent' unless C4::Context->preference('RentalsInNoissuesCharge');
1089 unless ( C4::Context->preference('ManInvInNoissuesCharge') ) {
1090 my $dbh = C4::Context->dbh;
1091 my $man_inv_types = $dbh->selectcol_arrayref(qq{SELECT authorised_value FROM authorised_values WHERE category = 'MANUAL_INV'});
1092 push @not_fines, map substr($_, 0, $ACCOUNT_TYPE_LENGTH), @$man_inv_types;
1094 my %not_fine = map {$_ => 1} @not_fines;
1096 my ($total, $acctlines) = GetMemberAccountRecords($borrowernumber);
1097 my $other_charges = 0;
1098 foreach (@$acctlines) {
1099 $other_charges += $_->{amountoutstanding} if $not_fine{ substr($_->{accounttype}, 0, $ACCOUNT_TYPE_LENGTH) };
1102 return ( $total, $total - $other_charges, $other_charges);
1105 =head2 GetBorNotifyAcctRecord
1107 ($total, $acctlines, $count) = &GetBorNotifyAcctRecord($params,$notifyid);
1109 Looks up accounting data for the patron with the given borrowernumber per file number.
1111 C<&GetBorNotifyAcctRecord> returns a three-element array. C<$acctlines> is a
1112 reference-to-array, where each element is a reference-to-hash; the
1113 keys are the fields of the C<accountlines> table in the Koha database.
1114 C<$count> is the number of elements in C<$acctlines>. C<$total> is the
1115 total amount outstanding for all of the account lines.
1119 sub GetBorNotifyAcctRecord {
1120 my ( $borrowernumber, $notifyid ) = @_;
1121 my $dbh = C4::Context->dbh;
1124 my $sth = $dbh->prepare(
1127 WHERE borrowernumber=?
1129 AND amountoutstanding != '0'
1130 ORDER BY notify_id,accounttype
1133 $sth->execute( $borrowernumber, $notifyid );
1135 while ( my $data = $sth->fetchrow_hashref ) {
1136 if ( $data->{itemnumber} ) {
1137 my $biblio = GetBiblioFromItemNumber( $data->{itemnumber} );
1138 $data->{biblionumber} = $biblio->{biblionumber};
1139 $data->{title} = $biblio->{title};
1141 $acctlines[$numlines] = $data;
1143 $total += int(100 * $data->{'amountoutstanding'});
1146 return ( $total, \@acctlines, $numlines );
1149 =head2 checkuniquemember (OUEST-PROVENCE)
1151 ($result,$categorycode) = &checkuniquemember($collectivity,$surname,$firstname,$dateofbirth);
1153 Checks that a member exists or not in the database.
1155 C<&result> is nonzero (=exist) or 0 (=does not exist)
1156 C<&categorycode> is from categorycode table
1157 C<&collectivity> is 1 (= we add a collectivity) or 0 (= we add a physical member)
1158 C<&surname> is the surname
1159 C<&firstname> is the firstname (only if collectivity=0)
1160 C<&dateofbirth> is the date of birth in ISO format (only if collectivity=0)
1164 # FIXME: This function is not legitimate. Multiple patrons might have the same first/last name and birthdate.
1165 # This is especially true since first name is not even a required field.
1167 sub checkuniquemember {
1168 my ( $collectivity, $surname, $firstname, $dateofbirth ) = @_;
1169 my $dbh = C4::Context->dbh;
1170 my $request = ($collectivity) ?
1171 "SELECT borrowernumber,categorycode FROM borrowers WHERE surname=? " :
1173 "SELECT borrowernumber,categorycode FROM borrowers WHERE surname=? and firstname=? and dateofbirth=?" :
1174 "SELECT borrowernumber,categorycode FROM borrowers WHERE surname=? and firstname=?";
1175 my $sth = $dbh->prepare($request);
1176 if ($collectivity) {
1177 $sth->execute( uc($surname) );
1178 } elsif($dateofbirth){
1179 $sth->execute( uc($surname), ucfirst($firstname), $dateofbirth );
1181 $sth->execute( uc($surname), ucfirst($firstname));
1183 my @data = $sth->fetchrow;
1184 ( $data[0] ) and return $data[0], $data[1];
1188 sub checkcardnumber {
1189 my ( $cardnumber, $borrowernumber ) = @_;
1191 # If cardnumber is null, we assume they're allowed.
1192 return 0 unless defined $cardnumber;
1194 my $dbh = C4::Context->dbh;
1195 my $query = "SELECT * FROM borrowers WHERE cardnumber=?";
1196 $query .= " AND borrowernumber <> ?" if ($borrowernumber);
1197 my $sth = $dbh->prepare($query);
1200 ( $borrowernumber ? $borrowernumber : () )
1203 return 1 if $sth->fetchrow_hashref;
1205 my ( $min_length, $max_length ) = get_cardnumber_length();
1207 if length $cardnumber > $max_length
1208 or length $cardnumber < $min_length;
1213 =head2 get_cardnumber_length
1215 my ($min, $max) = C4::Members::get_cardnumber_length()
1217 Returns the minimum and maximum length for patron cardnumbers as
1218 determined by the CardnumberLength system preference, the
1219 BorrowerMandatoryField system preference, and the width of the
1224 sub get_cardnumber_length {
1225 my ( $min, $max ) = ( 0, 16 ); # borrowers.cardnumber is a nullable varchar(16)
1226 $min = 1 if C4::Context->preference('BorrowerMandatoryField') =~ /cardnumber/;
1227 if ( my $cardnumber_length = C4::Context->preference('CardnumberLength') ) {
1228 # Is integer and length match
1229 if ( $cardnumber_length =~ m|^\d+$| ) {
1230 $min = $max = $cardnumber_length
1231 if $cardnumber_length >= $min
1232 and $cardnumber_length <= $max;
1234 # Else assuming it is a range
1235 elsif ( $cardnumber_length =~ m|(\d*),(\d*)| ) {
1236 $min = $1 if $1 and $min < $1;
1237 $max = $2 if $2 and $max > $2;
1241 return ( $min, $max );
1244 =head2 GetFirstValidEmailAddress
1246 $email = GetFirstValidEmailAddress($borrowernumber);
1248 Return the first valid email address for a borrower, given the borrowernumber. For now, the order
1249 is defined as email, emailpro, B_email. Returns the empty string if the borrower has no email
1254 sub GetFirstValidEmailAddress {
1255 my $borrowernumber = shift;
1256 my $dbh = C4::Context->dbh;
1257 my $sth = $dbh->prepare( "SELECT email, emailpro, B_email FROM borrowers where borrowernumber = ? ");
1258 $sth->execute( $borrowernumber );
1259 my $data = $sth->fetchrow_hashref;
1261 if ($data->{'email'}) {
1262 return $data->{'email'};
1263 } elsif ($data->{'emailpro'}) {
1264 return $data->{'emailpro'};
1265 } elsif ($data->{'B_email'}) {
1266 return $data->{'B_email'};
1272 =head2 GetNoticeEmailAddress
1274 $email = GetNoticeEmailAddress($borrowernumber);
1276 Return the email address of borrower used for notices, given the borrowernumber.
1277 Returns the empty string if no email address.
1281 sub GetNoticeEmailAddress {
1282 my $borrowernumber = shift;
1284 my $which_address = C4::Context->preference("AutoEmailPrimaryAddress");
1285 # if syspref is set to 'first valid' (value == OFF), look up email address
1286 if ( $which_address eq 'OFF' ) {
1287 return GetFirstValidEmailAddress($borrowernumber);
1289 # specified email address field
1290 my $dbh = C4::Context->dbh;
1291 my $sth = $dbh->prepare( qq{
1292 SELECT $which_address AS primaryemail
1294 WHERE borrowernumber=?
1296 $sth->execute($borrowernumber);
1297 my $data = $sth->fetchrow_hashref;
1298 return $data->{'primaryemail'} || '';
1301 =head2 GetExpiryDate
1303 $expirydate = GetExpiryDate($categorycode, $dateenrolled);
1305 Calculate expiry date given a categorycode and starting date. Date argument must be in ISO format.
1306 Return date is also in ISO format.
1311 my ( $categorycode, $dateenrolled ) = @_;
1313 if ($categorycode) {
1314 my $dbh = C4::Context->dbh;
1315 my $sth = $dbh->prepare("SELECT enrolmentperiod,enrolmentperioddate FROM categories WHERE categorycode=?");
1316 $sth->execute($categorycode);
1317 $enrolments = $sth->fetchrow_hashref;
1319 # die "GetExpiryDate: for enrollmentperiod $enrolmentperiod (category '$categorycode') starting $dateenrolled.\n";
1320 my @date = split (/-/,$dateenrolled);
1321 if($enrolments->{enrolmentperiod}){
1322 return sprintf("%04d-%02d-%02d", Add_Delta_YM(@date,0,$enrolments->{enrolmentperiod}));
1324 return $enrolments->{enrolmentperioddate};
1328 =head2 GetUpcomingMembershipExpires
1330 my $expires = GetUpcomingMembershipExpires({
1331 branch => $branch, before => $before, after => $after,
1334 $branch is an optional branch code.
1335 $before/$after is an optional number of days before/after the date that
1336 is set by the preference MembershipExpiryDaysNotice.
1337 If the pref would be 14, before 2 and after 3, you will get all expires
1342 sub GetUpcomingMembershipExpires {
1343 my ( $params ) = @_;
1344 my $before = $params->{before} || 0;
1345 my $after = $params->{after} || 0;
1346 my $branch = $params->{branch};
1348 my $dbh = C4::Context->dbh;
1349 my $days = C4::Context->preference("MembershipExpiryDaysNotice") || 0;
1350 my $date1 = dt_from_string->add( days => $days - $before );
1351 my $date2 = dt_from_string->add( days => $days + $after );
1352 $date1= output_pref({ dt => $date1, dateformat => 'iso', dateonly => 1 });
1353 $date2= output_pref({ dt => $date2, dateformat => 'iso', dateonly => 1 });
1356 SELECT borrowers.*, categories.description,
1357 branches.branchname, branches.branchemail FROM borrowers
1358 LEFT JOIN branches USING (branchcode)
1359 LEFT JOIN categories USING (categorycode)
1362 $query.= 'WHERE branchcode=? AND dateexpiry BETWEEN ? AND ?';
1364 $query.= 'WHERE dateexpiry BETWEEN ? AND ?';
1367 my $sth = $dbh->prepare( $query );
1368 my @pars = $branch? ( $branch ): ();
1369 push @pars, $date1, $date2;
1370 $sth->execute( @pars );
1371 my $results = $sth->fetchall_arrayref( {} );
1375 =head2 GetborCatFromCatType
1377 ($codes_arrayref, $labels_hashref) = &GetborCatFromCatType();
1379 Looks up the different types of borrowers in the database. Returns two
1380 elements: a reference-to-array, which lists the borrower category
1381 codes, and a reference-to-hash, which maps the borrower category codes
1382 to category descriptions.
1387 sub GetborCatFromCatType {
1388 my ( $category_type, $action, $no_branch_limit ) = @_;
1390 my $branch_limit = $no_branch_limit
1392 : C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1394 # FIXME - This API seems both limited and dangerous.
1395 my $dbh = C4::Context->dbh;
1398 SELECT categories.categorycode, categories.description
1402 LEFT JOIN categories_branches ON categories.categorycode = categories_branches.categorycode
1405 $request .= " $action ";
1406 $request .= " AND (branchcode = ? OR branchcode IS NULL) GROUP BY description" if $branch_limit;
1408 $request .= " WHERE branchcode = ? OR branchcode IS NULL GROUP BY description" if $branch_limit;
1410 $request .= " ORDER BY categorycode";
1412 my $sth = $dbh->prepare($request);
1414 $action ? $category_type : (),
1415 $branch_limit ? $branch_limit : ()
1421 while ( my $data = $sth->fetchrow_hashref ) {
1422 push @codes, $data->{'categorycode'};
1423 $labels{ $data->{'categorycode'} } = $data->{'description'};
1426 return ( \@codes, \%labels );
1429 =head2 GetBorrowercategory
1431 $hashref = &GetBorrowercategory($categorycode);
1433 Given the borrower's category code, the function returns the corresponding
1434 data hashref for a comprehensive information display.
1438 sub GetBorrowercategory {
1440 my $dbh = C4::Context->dbh;
1444 "SELECT description,dateofbirthrequired,upperagelimit,category_type
1446 WHERE categorycode = ?"
1448 $sth->execute($catcode);
1450 $sth->fetchrow_hashref;
1454 } # sub getborrowercategory
1457 =head2 GetBorrowerCategorycode
1459 $categorycode = &GetBorrowerCategoryCode( $borrowernumber );
1461 Given the borrowernumber, the function returns the corresponding categorycode
1465 sub GetBorrowerCategorycode {
1466 my ( $borrowernumber ) = @_;
1467 my $dbh = C4::Context->dbh;
1468 my $sth = $dbh->prepare( qq{
1471 WHERE borrowernumber = ?
1473 $sth->execute( $borrowernumber );
1474 return $sth->fetchrow;
1477 =head2 GetBorrowercategoryList
1479 $arrayref_hashref = &GetBorrowercategoryList;
1480 If no category code provided, the function returns all the categories.
1484 sub GetBorrowercategoryList {
1485 my $no_branch_limit = @_ ? shift : 0;
1486 my $branch_limit = $no_branch_limit
1488 : C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1489 my $dbh = C4::Context->dbh;
1490 my $query = "SELECT categories.* FROM categories";
1492 LEFT JOIN categories_branches ON categories.categorycode = categories_branches.categorycode
1493 WHERE branchcode = ? OR branchcode IS NULL GROUP BY description
1495 $query .= " ORDER BY description";
1496 my $sth = $dbh->prepare( $query );
1497 $sth->execute( $branch_limit ? $branch_limit : () );
1498 my $data = $sth->fetchall_arrayref( {} );
1501 } # sub getborrowercategory
1505 $dateofbirth,$date = &GetAge($date);
1507 this function return the borrowers age with the value of dateofbirth
1513 my ( $date, $date_ref ) = @_;
1515 if ( not defined $date_ref ) {
1516 $date_ref = sprintf( '%04d-%02d-%02d', Today() );
1519 my ( $year1, $month1, $day1 ) = split /-/, $date;
1520 my ( $year2, $month2, $day2 ) = split /-/, $date_ref;
1522 my $age = $year2 - $year1;
1523 if ( $month1 . $day1 > $month2 . $day2 ) {
1532 $borrower = C4::Members::SetAge($borrower, $datetimeduration);
1533 $borrower = C4::Members::SetAge($borrower, '0015-12-10');
1534 $borrower = C4::Members::SetAge($borrower, $datetimeduration, $datetime_reference);
1536 eval { $borrower = C4::Members::SetAge($borrower, '015-1-10'); };
1537 if ($@) {print $@;} #Catch a bad ISO Date or kill your script!
1539 This function sets the borrower's dateofbirth to match the given age.
1540 Optionally relative to the given $datetime_reference.
1542 @PARAM1 koha.borrowers-object
1543 @PARAM2 DateTime::Duration-object as the desired age
1544 OR a ISO 8601 Date. (To make the API more pleasant)
1545 @PARAM3 DateTime-object as the relative date, defaults to now().
1546 RETURNS The given borrower reference @PARAM1.
1547 DIES If there was an error with the ISO Date handling.
1553 my ( $borrower, $datetimeduration, $datetime_ref ) = @_;
1554 $datetime_ref = DateTime->now() unless $datetime_ref;
1556 if ($datetimeduration && ref $datetimeduration ne 'DateTime::Duration') {
1557 if ($datetimeduration =~ /^(\d{4})-(\d{2})-(\d{2})/) {
1558 $datetimeduration = DateTime::Duration->new(years => $1, months => $2, days => $3);
1561 die "C4::Members::SetAge($borrower, $datetimeduration), datetimeduration not a valid ISO 8601 Date!\n";
1565 my $new_datetime_ref = $datetime_ref->clone();
1566 $new_datetime_ref->subtract_duration( $datetimeduration );
1568 $borrower->{dateofbirth} = $new_datetime_ref->ymd();
1573 =head2 GetSortDetails (OUEST-PROVENCE)
1575 ($lib) = &GetSortDetails($category,$sortvalue);
1577 Returns the authorized value details
1578 C<&$lib>return value of authorized value details
1579 C<&$sortvalue>this is the value of authorized value
1580 C<&$category>this is the value of authorized value category
1584 sub GetSortDetails {
1585 my ( $category, $sortvalue ) = @_;
1586 my $dbh = C4::Context->dbh;
1587 my $query = qq|SELECT lib
1588 FROM authorised_values
1590 AND authorised_value=? |;
1591 my $sth = $dbh->prepare($query);
1592 $sth->execute( $category, $sortvalue );
1593 my $lib = $sth->fetchrow;
1594 return ($lib) if ($lib);
1595 return ($sortvalue) unless ($lib);
1598 =head2 MoveMemberToDeleted
1600 $result = &MoveMemberToDeleted($borrowernumber);
1602 Copy the record from borrowers to deletedborrowers table.
1603 The routine returns 1 for success, undef for failure.
1607 sub MoveMemberToDeleted {
1608 my ($member) = shift or return;
1610 my $schema = Koha::Database->new()->schema();
1611 my $borrowers_rs = $schema->resultset('Borrower');
1612 $borrowers_rs->result_class('DBIx::Class::ResultClass::HashRefInflator');
1613 my $borrower = $borrowers_rs->find($member);
1614 return unless $borrower;
1616 my $deleted = $schema->resultset('Deletedborrower')->create($borrower);
1618 return $deleted ? 1 : undef;
1623 DelMember($borrowernumber);
1625 This function remove directly a borrower whitout writing it on deleteborrower.
1626 + Deletes reserves for the borrower
1631 my $dbh = C4::Context->dbh;
1632 my $borrowernumber = shift;
1633 #warn "in delmember with $borrowernumber";
1634 return unless $borrowernumber; # borrowernumber is mandatory.
1635 # Delete Patron's holds
1636 my @holds = Koha::Holds->search({ borrowernumber => $borrowernumber });
1637 $_->delete for @holds;
1642 WHERE borrowernumber = ?
1644 my $sth = $dbh->prepare($query);
1645 $sth->execute($borrowernumber);
1646 logaction("MEMBERS", "DELETE", $borrowernumber, "") if C4::Context->preference("BorrowersLog");
1650 =head2 HandleDelBorrower
1652 HandleDelBorrower($borrower);
1654 When a member is deleted (DelMember in Members.pm), you should call me first.
1655 This routine deletes/moves lists and entries for the deleted member/borrower.
1656 Lists owned by the borrower are deleted, but entries from the borrower to
1657 other lists are kept.
1661 sub HandleDelBorrower {
1664 my $dbh = C4::Context->dbh;
1666 #Delete all lists and all shares of this borrower
1667 #Consistent with the approach Koha uses on deleting individual lists
1668 #Note that entries in virtualshelfcontents added by this borrower to
1669 #lists of others will be handled by a table constraint: the borrower
1670 #is set to NULL in those entries.
1671 $query="DELETE FROM virtualshelves WHERE owner=?";
1672 $dbh->do($query,undef,($borrower));
1675 #We could handle the above deletes via a constraint too.
1676 #But a new BZ report 11889 has been opened to discuss another approach.
1677 #Instead of deleting we could also disown lists (based on a pref).
1678 #In that way we could save shared and public lists.
1679 #The current table constraints support that idea now.
1680 #This pref should then govern the results of other routines/methods such as
1681 #Koha::Virtualshelf->new->delete too.
1684 =head2 ExtendMemberSubscriptionTo (OUEST-PROVENCE)
1686 $date = ExtendMemberSubscriptionTo($borrowerid, $date);
1688 Extending the subscription to a given date or to the expiry date calculated on ISO date.
1693 sub ExtendMemberSubscriptionTo {
1694 my ( $borrowerid,$date) = @_;
1695 my $dbh = C4::Context->dbh;
1696 my $borrower = GetMember('borrowernumber'=>$borrowerid);
1698 $date = (C4::Context->preference('BorrowerRenewalPeriodBase') eq 'dateexpiry') ?
1699 eval { output_pref( { dt => dt_from_string( $borrower->{'dateexpiry'} ), dateonly => 1, dateformat => 'iso' } ); }
1701 output_pref( { dt => dt_from_string, dateonly => 1, dateformat => 'iso' } );
1702 $date = GetExpiryDate( $borrower->{'categorycode'}, $date );
1704 my $sth = $dbh->do(<<EOF);
1706 SET dateexpiry='$date'
1707 WHERE borrowernumber='$borrowerid'
1710 AddEnrolmentFeeIfNeeded
( $borrower->{categorycode
}, $borrower->{borrowernumber
} );
1712 logaction
("MEMBERS", "RENEW", $borrower->{'borrowernumber'}, "Membership renewed")if C4
::Context
->preference("BorrowersLog");
1713 return $date if ($sth);
1717 =head2 GetTitles (OUEST-PROVENCE)
1719 ($borrowertitle)= &GetTitles();
1721 Looks up the different title . Returns array with all borrowers title
1726 my @borrowerTitle = split (/,|\|/,C4
::Context
->preference('BorrowersTitles'));
1727 unshift( @borrowerTitle, "" );
1728 my $count=@borrowerTitle;
1733 return ( \
@borrowerTitle);
1737 =head2 GetHideLostItemsPreference
1739 $hidelostitemspref = &GetHideLostItemsPreference($borrowernumber);
1741 Returns the HideLostItems preference for the patron category of the supplied borrowernumber
1742 C<&$hidelostitemspref>return value of function, 0 or 1
1746 sub GetHideLostItemsPreference
{
1747 my ($borrowernumber) = @_;
1748 my $dbh = C4
::Context
->dbh;
1749 my $query = "SELECT hidelostitems FROM borrowers,categories WHERE borrowers.categorycode = categories.categorycode AND borrowernumber = ?";
1750 my $sth = $dbh->prepare($query);
1751 $sth->execute($borrowernumber);
1752 my $hidelostitems = $sth->fetchrow;
1753 return $hidelostitems;
1756 =head2 GetBorrowersToExpunge
1758 $borrowers = &GetBorrowersToExpunge(
1759 not_borrowed_since => $not_borrowed_since,
1760 expired_before => $expired_before,
1761 category_code => $category_code,
1762 patron_list_id => $patron_list_id,
1763 branchcode => $branchcode
1766 This function get all borrowers based on the given criteria.
1770 sub GetBorrowersToExpunge
{
1773 my $filterdate = $params->{'not_borrowed_since'};
1774 my $filterexpiry = $params->{'expired_before'};
1775 my $filtercategory = $params->{'category_code'};
1776 my $filterbranch = $params->{'branchcode'} ||
1777 ((C4
::Context
->preference('IndependentBranches')
1778 && C4
::Context
->userenv
1779 && !C4
::Context
->IsSuperLibrarian()
1780 && C4
::Context
->userenv->{branch
})
1781 ? C4
::Context
->userenv->{branch
}
1783 my $filterpatronlist = $params->{'patron_list_id'};
1785 my $dbh = C4
::Context
->dbh;
1787 SELECT borrowers
.borrowernumber
,
1788 MAX
(old_issues
.timestamp
) AS latestissue
,
1789 MAX
(issues
.timestamp
) AS currentissue
1791 JOIN categories USING
(categorycode
)
1795 WHERE guarantorid IS NOT NULL
1796 AND guarantorid
<> 0
1797 ) as tmp ON borrowers
.borrowernumber
=tmp
.guarantorid
1798 LEFT JOIN old_issues USING
(borrowernumber
)
1799 LEFT JOIN issues USING
(borrowernumber
)|;
1800 if ( $filterpatronlist ){
1801 $query .= q
| LEFT JOIN patron_list_patrons USING
(borrowernumber
)|;
1803 $query .= q
| WHERE category_type
<> 'S'
1804 AND tmp
.guarantorid IS NULL
1807 if ( $filterbranch && $filterbranch ne "" ) {
1808 $query.= " AND borrowers.branchcode = ? ";
1809 push( @query_params, $filterbranch );
1811 if ( $filterexpiry ) {
1812 $query .= " AND dateexpiry < ? ";
1813 push( @query_params, $filterexpiry );
1815 if ( $filtercategory ) {
1816 $query .= " AND categorycode = ? ";
1817 push( @query_params, $filtercategory );
1819 if ( $filterpatronlist ){
1820 $query.=" AND patron_list_id = ? ";
1821 push( @query_params, $filterpatronlist );
1823 $query.=" GROUP BY borrowers.borrowernumber HAVING currentissue IS NULL ";
1824 if ( $filterdate ) {
1825 $query.=" AND ( latestissue < ? OR latestissue IS NULL ) ";
1826 push @query_params,$filterdate;
1828 warn $query if $debug;
1830 my $sth = $dbh->prepare($query);
1831 if (scalar(@query_params)>0){
1832 $sth->execute(@query_params);
1839 while ( my $data = $sth->fetchrow_hashref ) {
1840 push @results, $data;
1845 =head2 GetBorrowersWhoHaveNeverBorrowed
1847 $results = &GetBorrowersWhoHaveNeverBorrowed
1849 This function get all borrowers who have never borrowed.
1851 I<$result> is a ref to an array which all elements are a hasref.
1855 sub GetBorrowersWhoHaveNeverBorrowed
{
1856 my $filterbranch = shift ||
1857 ((C4
::Context
->preference('IndependentBranches')
1858 && C4
::Context
->userenv
1859 && !C4
::Context
->IsSuperLibrarian()
1860 && C4
::Context
->userenv->{branch
})
1861 ? C4
::Context
->userenv->{branch
}
1863 my $dbh = C4
::Context
->dbh;
1865 SELECT borrowers.borrowernumber,max(timestamp) as latestissue
1867 LEFT JOIN issues ON borrowers.borrowernumber = issues.borrowernumber
1868 WHERE issues.borrowernumber IS NULL
1871 if ($filterbranch && $filterbranch ne ""){
1872 $query.=" AND borrowers.branchcode= ?";
1873 push @query_params,$filterbranch;
1875 warn $query if $debug;
1877 my $sth = $dbh->prepare($query);
1878 if (scalar(@query_params)>0){
1879 $sth->execute(@query_params);
1886 while ( my $data = $sth->fetchrow_hashref ) {
1887 push @results, $data;
1892 =head2 GetBorrowersWithIssuesHistoryOlderThan
1894 $results = &GetBorrowersWithIssuesHistoryOlderThan($date)
1896 this function get all borrowers who has an issue history older than I<$date> given on input arg.
1898 I<$result> is a ref to an array which all elements are a hashref.
1899 This hashref is containt the number of time this borrowers has borrowed before I<$date> and the borrowernumber.
1903 sub GetBorrowersWithIssuesHistoryOlderThan
{
1904 my $dbh = C4
::Context
->dbh;
1905 my $date = shift ||POSIX
::strftime
("%Y-%m-%d",localtime());
1906 my $filterbranch = shift ||
1907 ((C4
::Context
->preference('IndependentBranches')
1908 && C4
::Context
->userenv
1909 && !C4
::Context
->IsSuperLibrarian()
1910 && C4
::Context
->userenv->{branch
})
1911 ? C4
::Context
->userenv->{branch
}
1914 SELECT count(borrowernumber) as n,borrowernumber
1916 WHERE returndate < ?
1917 AND borrowernumber IS NOT NULL
1920 push @query_params, $date;
1922 $query.=" AND branchcode = ?";
1923 push @query_params, $filterbranch;
1925 $query.=" GROUP BY borrowernumber ";
1926 warn $query if $debug;
1927 my $sth = $dbh->prepare($query);
1928 $sth->execute(@query_params);
1931 while ( my $data = $sth->fetchrow_hashref ) {
1932 push @results, $data;
1937 =head2 GetBorrowersNamesAndLatestIssue
1939 $results = &GetBorrowersNamesAndLatestIssueList(@borrowernumbers)
1941 this function get borrowers Names and surnames and Issue information.
1943 I<@borrowernumbers> is an array which all elements are borrowernumbers.
1944 This hashref is containt the number of time this borrowers has borrowed before I<$date> and the borrowernumber.
1948 sub GetBorrowersNamesAndLatestIssue
{
1949 my $dbh = C4
::Context
->dbh;
1950 my @borrowernumbers=@_;
1952 SELECT surname,lastname, phone, email,max(timestamp)
1954 LEFT JOIN issues ON borrowers.borrowernumber=issues.borrowernumber
1955 GROUP BY borrowernumber
1957 my $sth = $dbh->prepare($query);
1959 my $results = $sth->fetchall_arrayref({});
1965 IssueSlip($branchcode, $borrowernumber, $quickslip)
1967 Returns letter hash ( see C4::Letters::GetPreparedLetter )
1969 $quickslip is boolean, to indicate whether we want a quick slip
1971 IssueSlip populates ISSUESLIP and ISSUEQSLIP, and will make the following expansions:
2007 NOTE: Not all table fields are available, pleasee see GetPendingIssues for a list of available fields.
2012 my ($branch, $borrowernumber, $quickslip) = @_;
2014 # FIXME Check callers before removing this statement
2015 #return unless $borrowernumber;
2017 my @issues = @
{ GetPendingIssues
($borrowernumber) };
2019 for my $issue (@issues) {
2020 $issue->{date_due
} = $issue->{date_due_sql
};
2022 my $today = output_pref
({ dt
=> dt_from_string
, dateformat
=> 'iso', dateonly
=> 1 });
2023 if ( substr( $issue->{issuedate
}, 0, 10 ) eq $today
2024 or substr( $issue->{lastreneweddate
}, 0, 10 ) eq $today ) {
2030 # Sort on timestamp then on issuedate (useful for tests and could be if modified in a batch
2032 my $s = $b->{timestamp
} <=> $a->{timestamp
};
2034 $b->{issuedate
} <=> $a->{issuedate
} : $s;
2037 my ($letter_code, %repeat);
2039 $letter_code = 'ISSUEQSLIP';
2041 'checkedout' => [ map {
2044 'biblioitems' => $_,
2046 }, grep { $_->{'now'} } @issues ],
2050 $letter_code = 'ISSUESLIP';
2052 'checkedout' => [ map {
2055 'biblioitems' => $_,
2057 }, grep { !$_->{'overdue'} } @issues ],
2059 'overdue' => [ map {
2062 'biblioitems' => $_,
2064 }, grep { $_->{'overdue'} } @issues ],
2067 $_->{'timestamp'} = $_->{'newdate'};
2069 } @
{ GetNewsToDisplay
("slip",$branch) } ],
2073 return C4
::Letters
::GetPreparedLetter
(
2074 module
=> 'circulation',
2075 letter_code
=> $letter_code,
2076 branchcode
=> $branch,
2078 'branches' => $branch,
2079 'borrowers' => $borrowernumber,
2085 =head2 GetBorrowersWithEmail
2087 ([$borrnum,$userid], ...) = GetBorrowersWithEmail('me@example.com');
2089 This gets a list of users and their basic details from their email address.
2090 As it's possible for multiple user to have the same email address, it provides
2091 you with all of them. If there is no userid for the user, there will be an
2092 C<undef> there. An empty list will be returned if there are no matches.
2096 sub GetBorrowersWithEmail
{
2099 my $dbh = C4
::Context
->dbh;
2101 my $query = "SELECT borrowernumber, userid FROM borrowers WHERE email=?";
2102 my $sth=$dbh->prepare($query);
2103 $sth->execute($email);
2105 while (my $ref = $sth->fetch) {
2108 die "Failure searching for borrowers by email address: $sth->errstr" if $sth->err;
2112 =head2 AddMember_Opac
2116 sub AddMember_Opac
{
2117 my ( %borrower ) = @_;
2119 $borrower{'categorycode'} //= C4
::Context
->preference('PatronSelfRegistrationDefaultCategory');
2120 if (not defined $borrower{'password'}){
2121 my $sr = new String
::Random
;
2122 $sr->{'A'} = [ 'A'..'Z', 'a'..'z' ];
2123 my $password = $sr->randpattern("AAAAAAAAAA");
2124 $borrower{'password'} = $password;
2127 $borrower{'cardnumber'} = fixup_cardnumber
( $borrower{'cardnumber'} );
2129 my $borrowernumber = AddMember
(%borrower);
2131 return ( $borrowernumber, $borrower{'password'} );
2134 =head2 AddEnrolmentFeeIfNeeded
2136 AddEnrolmentFeeIfNeeded( $borrower->{categorycode}, $borrower->{borrowernumber} );
2138 Add enrolment fee for a patron if needed.
2142 sub AddEnrolmentFeeIfNeeded
{
2143 my ( $categorycode, $borrowernumber ) = @_;
2144 # check for enrollment fee & add it if needed
2145 my $dbh = C4
::Context
->dbh;
2146 my $sth = $dbh->prepare(q{
2149 WHERE categorycode=?
2151 $sth->execute( $categorycode );
2153 warn sprintf('Database returned the following error: %s', $sth->errstr);
2156 my ($enrolmentfee) = $sth->fetchrow;
2157 if ($enrolmentfee && $enrolmentfee > 0) {
2158 # insert fee in patron debts
2159 C4
::Accounts
::manualinvoice
( $borrowernumber, '', '', 'A', $enrolmentfee );
2168 my ( $borrowernumber ) = @_;
2170 my $sql = "SELECT COUNT(*) FROM issues WHERE date_due < NOW() AND borrowernumber = ?";
2171 my $sth = C4
::Context
->dbh->prepare( $sql );
2172 $sth->execute( $borrowernumber );
2173 my ( $count ) = $sth->fetchrow_array();
2178 =head2 DeleteExpiredOpacRegistrations
2180 Delete accounts that haven't been upgraded from the 'temporary' category
2181 Returns the number of removed patrons
2185 sub DeleteExpiredOpacRegistrations
{
2187 my $delay = C4
::Context
->preference('PatronSelfRegistrationExpireTemporaryAccountsDelay');
2188 my $category_code = C4
::Context
->preference('PatronSelfRegistrationDefaultCategory');
2190 return 0 if not $category_code or not defined $delay or $delay eq q
||;
2193 SELECT borrowernumber
2195 WHERE categorycode
= ? AND DATEDIFF
( NOW
(), dateenrolled
) > ?
|;
2197 my $dbh = C4
::Context
->dbh;
2198 my $sth = $dbh->prepare($query);
2199 $sth->execute( $category_code, $delay );
2201 while ( my ($borrowernumber) = $sth->fetchrow_array() ) {
2202 DelMember
($borrowernumber);
2208 =head2 DeleteUnverifiedOpacRegistrations
2210 Delete all unverified self registrations in borrower_modifications,
2211 older than the specified number of days.
2215 sub DeleteUnverifiedOpacRegistrations
{
2217 my $dbh = C4
::Context
->dbh;
2219 DELETE FROM borrower_modifications
2220 WHERE borrowernumber
= 0 AND DATEDIFF
( NOW
(), timestamp
) > ?
|;
2221 my $cnt=$dbh->do($sql, undef, ($days) );
2222 return $cnt eq '0E0'?
0: $cnt;
2225 sub GetOverduesForPatron
{
2226 my ( $borrowernumber ) = @_;
2230 FROM issues, items, biblio, biblioitems
2231 WHERE items.itemnumber=issues.itemnumber
2232 AND biblio.biblionumber = items.biblionumber
2233 AND biblio.biblionumber = biblioitems.biblionumber
2234 AND issues.borrowernumber = ?
2235 AND date_due < NOW()
2238 my $sth = C4
::Context
->dbh->prepare( $sql );
2239 $sth->execute( $borrowernumber );
2241 return $sth->fetchall_arrayref({});
2244 END { } # module clean-up code here (global destructor)