Marcel de Rooy
bc647bc21b
We should at least report some grand totals when fixing fine records. This patch also includes some cosmetic whitespace swapping. Turned one last into an if statement. Added a copyright statement too. Signed-off-by: Marcel de Rooy <m.de.rooy@rijksmuseum.nl> Signed-off-by: Kyle M Hall <kyle@bywatersolutions.com>
234 lines
8.4 KiB
Perl
Executable file
234 lines
8.4 KiB
Perl
Executable file
#!/usr/bin/perl
|
|
|
|
# Copyright 2016 Jacek Ablewicz
|
|
#
|
|
# This file is part of Koha.
|
|
#
|
|
# Koha is free software; you can redistribute it and/or modify it
|
|
# under the terms of the GNU General Public License as published by
|
|
# the Free Software Foundation; either version 3 of the License, or
|
|
# (at your option) any later version.
|
|
#
|
|
# Koha is distributed in the hope that it will be useful, but
|
|
# WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
# GNU General Public License for more details.
|
|
#
|
|
# You should have received a copy of the GNU General Public License
|
|
# along with Koha; if not, see <http://www.gnu.org/licenses>.
|
|
|
|
|
|
use Modern::Perl;
|
|
|
|
use C4::Context;
|
|
use C4::Overdues qw/CalcFine BorType/;
|
|
use C4::Log qw/logaction/;
|
|
|
|
use Koha::DateUtils;
|
|
use Getopt::Long;
|
|
|
|
my ($help, $verbose, $confirm, $log, $stdout_log);
|
|
|
|
GetOptions(
|
|
'h|help' => \$help,
|
|
'v|verbose' => \$verbose,
|
|
'l|log' => \$log,
|
|
'c|confirm' => \$confirm,
|
|
'p|print' => \$stdout_log
|
|
);
|
|
|
|
my $usage = << 'ENDUSAGE';
|
|
|
|
Script for fixing unclosed (FU), non accruing fine records, which
|
|
may still need FU -> F correction post-Bug 15675. For details,
|
|
see Bug 14390 & Bug 17135.
|
|
|
|
This script has the following parameters :
|
|
-h --help: this message
|
|
-l --log: log changes to the system logs
|
|
-c --confirm: commit changes (test only mode if not present)
|
|
-p --print: output affected fine records details to the STDOUT
|
|
-v --verbose
|
|
|
|
ENDUSAGE
|
|
|
|
{
|
|
if ($help) {
|
|
print $usage;
|
|
exit 0;
|
|
}
|
|
|
|
Bug_17135_fix({
|
|
'verbose' => $verbose, 'log' => $log,
|
|
'confirm' => $confirm, 'stdout_log' => $stdout_log
|
|
});
|
|
|
|
exit 0;
|
|
}
|
|
|
|
sub Bug_17135_fix {
|
|
my $params = shift;
|
|
|
|
my $verbose = $params->{'verbose'};
|
|
my $log = $params->{'log'};
|
|
my $confirm = $params->{'confirm'};
|
|
my $stdout_log = $params->{'stdout_log'};
|
|
|
|
my $control = C4::Context->preference('CircControl');
|
|
my $mode = C4::Context->preference('finesMode');
|
|
my $today = DateTime->now( time_zone => C4::Context->tz() );
|
|
my $dbh = C4::Context->dbh;
|
|
|
|
## fetch the unclosed FU fines linked to the issues by issue_id
|
|
my $acclines = getFinesForChecking();
|
|
|
|
Warn("Got ".scalar(@$acclines)." FU accountlines to check") if $verbose;
|
|
|
|
my $different_dates_cnt = 0;
|
|
my $not_due_not_accruning_cnt = 0;
|
|
my $due_not_accruning_cnt = 0;
|
|
my $forfixing = [];
|
|
my $old_date_pattern;
|
|
for my $fine (@$acclines) {
|
|
my $datedue = dt_from_string( $fine->{date_due} );
|
|
my $due = output_pref($datedue);
|
|
$fine->{current_due_date} = $due;
|
|
my $due_qr = qr/$due/;
|
|
## if the dates in fine description and in the issue record match,
|
|
## this is a legit post-Bug Bug 15675 accruing overdue fine
|
|
## which does not require any correction
|
|
next if ($fine->{description} =~ /$due_qr/);
|
|
|
|
if( !$old_date_pattern ) {
|
|
## for extracting old due date from fine description
|
|
## not used for fixing anything, logging/debug purposes only
|
|
$old_date_pattern = $due;
|
|
$old_date_pattern =~ s/[A-Za-z]/\[A-Za-z\]/g;
|
|
$old_date_pattern =~ s/[0-9]/\\d/g;
|
|
$old_date_pattern = qr/$old_date_pattern/;
|
|
}
|
|
if ($fine->{description} =~ / ($old_date_pattern)$/) {
|
|
my $old_date_due = $1;
|
|
$fine->{old_date_due} = $old_date_due;
|
|
### Warn("'$due' vs '$old_date_due'") if $verbose;
|
|
}
|
|
$fine->{old_date_due} //= 'unknown';
|
|
|
|
$different_dates_cnt++;
|
|
## after the last renewal, item is no longer due = it's not accruing,
|
|
## fine still needs to be closed
|
|
unless ($fine->{item_is_due}) {
|
|
$fine->{log_entry} = 'item not due, fine not accruing';
|
|
$not_due_not_accruning_cnt++;
|
|
push(@$forfixing, $fine);
|
|
next;
|
|
}
|
|
|
|
my $is_not_accruing = 0;
|
|
## item got due again after the last renewal, CalcFine() needs
|
|
## to be called to establish if the fine is accruning or not
|
|
{
|
|
my $statement;
|
|
if ( C4::Context->preference('item-level_itypes') ) {
|
|
$statement = "SELECT issues.*, items.itype as itemtype, items.homebranch, items.barcode, items.itemlost, items.replacementprice
|
|
FROM issues
|
|
LEFT JOIN items USING (itemnumber)
|
|
WHERE date_due < NOW() AND issue_id = ?
|
|
";
|
|
} else {
|
|
$statement = "SELECT issues.*, biblioitems.itemtype, items.itype, items.homebranch, items.barcode, items.itemlost, replacementprice
|
|
FROM issues
|
|
LEFT JOIN items USING (itemnumber)
|
|
LEFT JOIN biblioitems USING (biblioitemnumber)
|
|
WHERE date_due < NOW() AND issue_id = ?
|
|
";
|
|
}
|
|
|
|
my $sth = $dbh->prepare($statement);
|
|
$sth->execute($fine->{issue_id});
|
|
my $overdues = $sth->fetchall_arrayref({});
|
|
last if (@$overdues != 1);
|
|
my $overdue = $overdues->[0];
|
|
|
|
### last if $overdue->{itemlost}; ## arguable
|
|
my $borrower = BorType( $overdue->{borrowernumber} );
|
|
my $branchcode =
|
|
( $control eq 'ItemHomeLibrary' ) ? $overdue->{homebranch}
|
|
: ( $control eq 'PatronLibrary' ) ? $borrower->{branchcode}
|
|
: $overdue->{branchcode};
|
|
|
|
my ($amount) = CalcFine( $overdue, $borrower->{categorycode}, $branchcode, $datedue, $today );
|
|
### Warn("CalcFine() returned '$amount'");
|
|
last if ($amount > 0); ## accruing fine, skip closing
|
|
|
|
## If we are here: item is due again, but fine is not accruing
|
|
## yet (overdue may be in the grace period, 1st charging period
|
|
## is not over yet, all days beetwen due date and today are
|
|
## holidays etc.). Old fine record needs to be closed
|
|
$is_not_accruing = 1;
|
|
}
|
|
|
|
if ($is_not_accruing) {
|
|
$fine->{log_entry} = 'item due, fine not accruing yet';
|
|
$due_not_accruning_cnt++;
|
|
push(@$forfixing, $fine);
|
|
};
|
|
}
|
|
|
|
if( $verbose ) {
|
|
Warn( "Fine records with mismatched old vs current due dates: $different_dates_cnt" );
|
|
Warn( "Non-accruing accountlines FU records (item not due): ".$not_due_not_accruning_cnt );
|
|
Warn( "Non-accruing accountlines FU records (item due): ".$due_not_accruning_cnt );
|
|
}
|
|
|
|
my $updated_cnt = 0;
|
|
my $update_sql = "UPDATE accountlines SET accounttype = 'F' WHERE accounttype = 'FU' AND accountlines_id = ? LIMIT 1";
|
|
for my $fine (@$forfixing) {
|
|
my $logentry = "Closing old FU fine (Bug 17135); accountlines_id=".$fine->{accountlines_id};
|
|
$logentry .= " issue_id=".$fine->{issue_id}." amount=".$fine->{amount};
|
|
$logentry .= "; due dates (old, current): '".$fine->{old_date_due}."', '".$fine->{current_due_date}."'";
|
|
$logentry .= "; reason: ".$fine->{log_entry};
|
|
print($logentry."\n") if ($stdout_log);
|
|
|
|
next unless ($confirm && $mode eq 'production');
|
|
my $rows_affected = $dbh->do($update_sql, undef, $fine->{accountlines_id});
|
|
$updated_cnt += $rows_affected;
|
|
logaction("FINES", "FU", $fine->{borrowernumber}, $logentry) if ($log);
|
|
}
|
|
|
|
# Regardless of verbose, we report at least a number here
|
|
if( @$forfixing > 0 ) {
|
|
if( $confirm && $mode eq 'production') {
|
|
Warn( "Database update done, $updated_cnt".
|
|
( @$forfixing == $updated_cnt? "": ( "/". @$forfixing )).
|
|
" fine records closed successfully." );
|
|
} else {
|
|
Warn( "Dry run (test only mode), skipping ". @$forfixing.
|
|
" fine records." );
|
|
}
|
|
} else {
|
|
Warn( "No fine records needed to be fixed" );
|
|
}
|
|
}
|
|
|
|
sub getFinesForChecking {
|
|
my $dbh = C4::Context->dbh;
|
|
my $query = "SELECT acc.*, iss.date_due,
|
|
IF(iss.date_due < NOW(), 1, 0) AS item_is_due
|
|
FROM accountlines acc
|
|
LEFT JOIN issues iss USING (issue_id)
|
|
WHERE accounttype = 'FU'
|
|
AND iss.issue_id IS NOT NULL
|
|
AND iss.borrowernumber = acc.borrowernumber
|
|
AND iss.itemnumber = acc.itemnumber
|
|
ORDER BY acc.borrowernumber, acc.issue_id
|
|
";
|
|
|
|
my $sth = $dbh->prepare($query);
|
|
$sth->execute();
|
|
return $sth->fetchall_arrayref({});
|
|
}
|
|
|
|
sub Warn {
|
|
print join("\n", @_, '');
|
|
}
|