Line 0
Link Here
|
0 |
- |
1 |
#!/usr/bin/perl |
|
|
2 |
|
3 |
# This file is part of Koha. |
4 |
# |
5 |
# Koha is free software; you can redistribute it and/or modify it |
6 |
# under the terms of the GNU General Public License as published by |
7 |
# the Free Software Foundation; either version 3 of the License, or |
8 |
# (at your option) any later version. |
9 |
# |
10 |
# Koha is distributed in the hope that it will be useful, but |
11 |
# WITHOUT ANY WARRANTY; without even the implied warranty of |
12 |
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
13 |
# GNU General Public License for more details. |
14 |
# |
15 |
# You should have received a copy of the GNU General Public License |
16 |
# along with Koha; if not, see <http://www.gnu.org/licenses>. |
17 |
|
18 |
|
19 |
use Modern::Perl; |
20 |
|
21 |
use C4::Context; |
22 |
use C4::Overdues qw/CalcFine BorType/; |
23 |
use C4::Log qw/logaction/; |
24 |
|
25 |
use Koha::DateUtils; |
26 |
use Getopt::Long; |
27 |
|
28 |
my ($help, $verbose, $confirm, $log); |
29 |
|
30 |
GetOptions( |
31 |
'h|help' => \$help, |
32 |
'v|verbose' => \$verbose, |
33 |
'l|log' => \$log, |
34 |
'c|confirm' => \$confirm |
35 |
); |
36 |
|
37 |
my $usage = << 'ENDUSAGE'; |
38 |
|
39 |
Script for fixing unclosed (FU), non accruing fine records, which |
40 |
may still need FU -> F correction post-Bug 15675. For details, |
41 |
see Bug 14390 & Bug 17135. |
42 |
|
43 |
This script has the following parameters : |
44 |
-h --help: this message |
45 |
-l --log: log changes to the system logs |
46 |
-c --confirm: commit changes (test only mode if not present) |
47 |
-v --verbose |
48 |
|
49 |
ENDUSAGE |
50 |
|
51 |
{ |
52 |
if ($help) { |
53 |
print $usage; |
54 |
exit 0; |
55 |
} |
56 |
|
57 |
Bug_17135_fix({ |
58 |
'verbose' => $verbose, 'log' => $log, 'confirm' => $confirm |
59 |
}); |
60 |
|
61 |
exit 0; |
62 |
} |
63 |
|
64 |
sub Bug_17135_fix { |
65 |
my $params = shift; |
66 |
|
67 |
my $verbose = $params->{'verbose'}; |
68 |
my $log = $params->{'log'}; |
69 |
my $confirm = $params->{'confirm'}; |
70 |
|
71 |
my $control = C4::Context->preference('CircControl'); |
72 |
my $mode = C4::Context->preference('finesMode'); |
73 |
my $today = DateTime->now( time_zone => C4::Context->tz() ); |
74 |
my $dbh = C4::Context->dbh; |
75 |
|
76 |
## fetch the unclosed FU fines linked to the issues by issue_id |
77 |
my $acclines = getFinesForChecking(); |
78 |
|
79 |
Warn("Got ".scalar(@$acclines)." FU accountlines to check") if $verbose; |
80 |
|
81 |
my $different_dates_cnt = 0; |
82 |
my $not_due_not_accruning_cnt = 0; |
83 |
my $due_not_accruning_cnt = 0; |
84 |
my $forfixing = []; |
85 |
my $old_date_pattern; |
86 |
for my $fine (@$acclines) { |
87 |
my $datedue = dt_from_string( $fine->{date_due} ); |
88 |
my $due = output_pref($datedue); |
89 |
$fine->{current_due_date} = $due; |
90 |
my $due_qr = qr/$due/; |
91 |
## if the dates in fine description and in the issue record match, |
92 |
## this is a legit post-Bug Bug 15675 accruing overdue fine |
93 |
## which does not require any correction |
94 |
next if ($fine->{description} =~ /$due_qr/); |
95 |
|
96 |
{ |
97 |
## for extracting old due date from fine description |
98 |
## not used for fixing anything, logging/debug purposes only |
99 |
last if $old_date_pattern; |
100 |
$old_date_pattern = $due; |
101 |
$old_date_pattern =~ s/[A-Za-z]/\[A-Za-z\]/g; |
102 |
$old_date_pattern =~ s/[0-9]/\\d/g; |
103 |
$old_date_pattern = qr/$old_date_pattern/; |
104 |
} |
105 |
if ($fine->{description} =~ / ($old_date_pattern)$/) { |
106 |
my $old_date_due = $1; |
107 |
$fine->{old_date_due} = $old_date_due; |
108 |
### Warn("'$due' vs '$old_date_due'") if $verbose; |
109 |
} |
110 |
$fine->{old_date_due} //= 'unknown'; |
111 |
|
112 |
$different_dates_cnt++; |
113 |
## after the last renewal, item is no longer due = it's not accruing, |
114 |
## fine still needs to be closed |
115 |
unless ($fine->{item_is_due}) { |
116 |
$fine->{log_entry} = 'item not due, fine not accruing'; |
117 |
$not_due_not_accruning_cnt++; |
118 |
push(@$forfixing, $fine); |
119 |
next; |
120 |
} |
121 |
|
122 |
my $is_not_accruing = 0; |
123 |
## item got due again after the last renewal, CalcFine() needs |
124 |
## to be called to establish if the fine is accruning or not |
125 |
{ |
126 |
my $statement; |
127 |
if ( C4::Context->preference('item-level_itypes') ) { |
128 |
$statement = "SELECT issues.*, items.itype as itemtype, items.homebranch, items.barcode, items.itemlost, items.replacementprice |
129 |
FROM issues |
130 |
LEFT JOIN items USING (itemnumber) |
131 |
WHERE date_due < NOW() AND issue_id = ? |
132 |
"; |
133 |
} else { |
134 |
$statement = "SELECT issues.*, biblioitems.itemtype, items.itype, items.homebranch, items.barcode, items.itemlost, replacementprice |
135 |
FROM issues |
136 |
LEFT JOIN items USING (itemnumber) |
137 |
LEFT JOIN biblioitems USING (biblioitemnumber) |
138 |
WHERE date_due < NOW() AND issue_id = ? |
139 |
"; |
140 |
} |
141 |
|
142 |
my $sth = $dbh->prepare($statement); |
143 |
$sth->execute($fine->{issue_id}); |
144 |
my $overdues = $sth->fetchall_arrayref({}); |
145 |
last if (@$overdues != 1); |
146 |
my $overdue = $overdues->[0]; |
147 |
|
148 |
### last if $overdue->{itemlost}; ## arguable |
149 |
my $borrower = BorType( $overdue->{borrowernumber} ); |
150 |
my $branchcode = |
151 |
( $control eq 'ItemHomeLibrary' ) ? $overdue->{homebranch} |
152 |
: ( $control eq 'PatronLibrary' ) ? $borrower->{branchcode} |
153 |
: $overdue->{branchcode}; |
154 |
|
155 |
my ($amount) = CalcFine( $overdue, $borrower->{categorycode}, $branchcode, $datedue, $today ); |
156 |
### Warn("CalcFine() returned '$amount'"); |
157 |
last if ($amount > 0); ## accruing fine, skip closing |
158 |
|
159 |
## If we are here: item is due again, but fine is not accruing |
160 |
## yet (overdue may be in the grace period, 1st charging period |
161 |
## is not over yet, all days beetwen due date and today are |
162 |
## holidays etc.). Old fine record needs to be closed |
163 |
$is_not_accruing = 1; |
164 |
} |
165 |
|
166 |
if ($is_not_accruing) { |
167 |
$fine->{log_entry} = 'item due, fine not accruing yet'; |
168 |
$due_not_accruning_cnt++; |
169 |
push(@$forfixing, $fine); |
170 |
}; |
171 |
} |
172 |
|
173 |
Warn("Fine records with mismatched old vs current due dates: $different_dates_cnt") if $verbose; |
174 |
Warn("Non-accruing accountlines FU records (item not due): ".$not_due_not_accruning_cnt); |
175 |
Warn("Non-accruing accountlines FU records (item due): ".$due_not_accruning_cnt); |
176 |
|
177 |
my $update_sql = "UPDATE accountlines SET accounttype = 'F' WHERE accounttype = 'FU' AND accountlines_id = ? LIMIT 1"; |
178 |
for my $fine (@$forfixing) { |
179 |
my $logentry = "Closing old FU fine (Bug 17135); accountlines_id=".$fine->{accountlines_id}; |
180 |
$logentry .= " issue_id=".$fine->{issue_id}." amount=".$fine->{amount}; |
181 |
$logentry .= "; due dates (old, current): '".$fine->{old_date_due}."', '".$fine->{current_due_date}."'"; |
182 |
$logentry .= "; reason: ".$fine->{log_entry}; |
183 |
|
184 |
unless ($mode eq 'production') { |
185 |
print $logentry."\n"; ## FIXME? |
186 |
next; |
187 |
} |
188 |
unless ($confirm) { |
189 |
Warn("Dry run (test only mode), skipping database changes."); |
190 |
last; |
191 |
} |
192 |
|
193 |
$dbh->do($update_sql, undef, $fine->{accountlines_id}); |
194 |
logaction("FINES", "FU", $fine->{borrowernumber}, $logentry) if ($log); |
195 |
} |
196 |
} |
197 |
|
198 |
sub getFinesForChecking { |
199 |
my $dbh = C4::Context->dbh; |
200 |
my $query = "SELECT acc.*, iss.date_due, |
201 |
IF(iss.date_due < NOW(), 1, 0) AS item_is_due |
202 |
FROM accountlines acc |
203 |
LEFT JOIN issues iss USING (issue_id) |
204 |
WHERE accounttype = 'FU' |
205 |
AND iss.issue_id IS NOT NULL |
206 |
ORDER BY acc.borrowernumber, acc.issue_id |
207 |
"; |
208 |
|
209 |
my $sth = $dbh->prepare($query); |
210 |
$sth->execute(); |
211 |
return $sth->fetchall_arrayref({}); |
212 |
} |
213 |
|
214 |
sub Warn { |
215 |
print STDERR join("\n", @_, ''); |
216 |
} |