Bug 26922: Regression tests
[koha.git] / circ / overdue.pl
blob1ce791fe24df8f48779bc952d26fa41d47b4a4ca
1 #!/usr/bin/perl
4 # Copyright 2000-2002 Katipo Communications
5 # Parts copyright 2010 BibLibre
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>.
22 use Modern::Perl;
23 use C4::Context;
24 use C4::Output;
25 use CGI qw(-oldstyle_urls -utf8);
26 use C4::Auth;
27 use C4::Debug;
28 use Text::CSV_XS;
29 use Koha::DateUtils;
30 use DateTime;
31 use DateTime::Format::MySQL;
33 my $input = CGI->new;
34 my $showall = $input->param('showall');
35 my $bornamefilter = $input->param('borname') || '';
36 my $borcatfilter = $input->param('borcat') || '';
37 my $itemtypefilter = $input->param('itemtype') || '';
38 my $borflagsfilter = $input->param('borflag') || '';
39 my $branchfilter = $input->param('branch') || '';
40 my $homebranchfilter = $input->param('homebranch') || '';
41 my $holdingbranchfilter = $input->param('holdingbranch') || '';
42 my $dateduefrom = $input->param('dateduefrom');
43 my $datedueto = $input->param('datedueto');
44 my $op = $input->param('op') || '';
46 if ( $dateduefrom ) {
47 $dateduefrom = dt_from_string( $dateduefrom );
49 if ( $datedueto ) {
50 $datedueto = dt_from_string( $datedueto )->set_hour(23)->set_minute(59);
53 my $filters = {
54 itemtype => $itemtypefilter,
55 borname => $bornamefilter,
56 borcat => $borcatfilter,
57 itemtype => $itemtypefilter,
58 borflag => $borflagsfilter,
59 branch => $branchfilter,
60 homebranch => $homebranchfilter,
61 holdingbranch => $holdingbranchfilter,
62 dateduefrom => $dateduefrom,
63 datedueto => $datedueto,
66 my $isfiltered = $op =~ /apply/i && $op =~ /filter/i;
67 my $noreport = C4::Context->preference('FilterBeforeOverdueReport') && ! $isfiltered && $op ne "csv";
69 my ( $template, $loggedinuser, $cookie ) = get_template_and_user(
71 template_name => "circ/overdue.tt",
72 query => $input,
73 type => "intranet",
74 flagsrequired => { circulate => "overdues_report" },
75 debug => 1,
79 our $logged_in_user = Koha::Patrons->find( $loggedinuser );
81 my $dbh = C4::Context->dbh;
83 my $req;
84 $req = $dbh->prepare( "select categorycode, description from categories order by description");
85 $req->execute;
86 my @borcatloop;
87 while (my ($catcode, $description) =$req->fetchrow) {
88 push @borcatloop, {
89 value => $catcode,
90 selected => $catcode eq $borcatfilter ? 1 : 0,
91 catname => $description,
95 $req = $dbh->prepare( "select itemtype, description from itemtypes order by description");
96 $req->execute;
97 my @itemtypeloop;
98 while (my ($itemtype, $description) =$req->fetchrow) {
99 push @itemtypeloop, {
100 value => $itemtype,
101 selected => $itemtype eq $itemtypefilter ? 1 : 0,
102 itemtypename => $description,
106 # Filtering by Patron Attributes
107 # @patron_attr_filter_loop is non empty if there are any patron attribute filters
108 # %cgi_attrcode_to_attrvalues contains the patron attribute filter values, as returned by the CGI
109 # %borrowernumber_to_attributes is populated by those borrowernumbers matching the patron attribute filters
111 my %cgi_attrcode_to_attrvalues; # ( patron_attribute_code => [ zero or more attribute filter values from the CGI ] )
112 for my $attrcode (grep { /^patron_attr_filter_/ } $input->multi_param) {
113 if (my @attrvalues = grep { length($_) > 0 } $input->multi_param($attrcode)) {
114 $attrcode =~ s/^patron_attr_filter_//;
115 $cgi_attrcode_to_attrvalues{$attrcode} = \@attrvalues;
116 print STDERR ">>>param($attrcode)[@{[scalar @attrvalues]}] = '@attrvalues'\n" if $debug;
119 my $have_pattr_filter_data = keys(%cgi_attrcode_to_attrvalues) > 0;
121 my @patron_attr_filter_loop; # array of [ domid cgivalue ismany isclone ordinal code description repeatable authorised_value_category ]
123 my $sth = $dbh->prepare('SELECT code,description,repeatable,authorised_value_category
124 FROM borrower_attribute_types
125 WHERE staff_searchable <> 0
126 ORDER BY description');
127 $sth->execute();
128 my $ordinal = 0;
129 while (my $row = $sth->fetchrow_hashref) {
130 $row->{ordinal} = $ordinal;
131 my $code = $row->{code};
132 my $cgivalues = $cgi_attrcode_to_attrvalues{$code} || [ '' ];
133 my $isclone = 0;
134 $row->{ismany} = @$cgivalues > 1;
135 my $serial = 0;
136 for (@$cgivalues) {
137 $row->{domid} = $ordinal * 1000 + $serial;
138 $row->{cgivalue} = $_;
139 $row->{isclone} = $isclone;
140 push @patron_attr_filter_loop, { %$row }; # careful: must store a *deep copy* of the modified row
141 } continue { $isclone = 1, ++$serial }
142 } continue { ++$ordinal }
144 my %borrowernumber_to_attributes; # hash of { borrowernumber => { attrcode => [ [val,display], [val,display], ... ] } }
145 # i.e. val differs from display when attr is an authorised value
146 if (@patron_attr_filter_loop) {
147 # MAYBE FIXME: currently, *all* borrower_attributes are loaded into %borrowernumber_to_attributes
148 # then filtered and honed down to match the patron attribute filters. If this is
149 # too resource intensive, MySQL can be used to do the filtering, i.e. rewire the
150 # SQL below to select only those attribute values that match the filters.
152 my $sql = q(SELECT borrowernumber AS bn, b.code, attribute AS val, category AS avcategory, lib AS avdescription
153 FROM borrower_attributes b
154 JOIN borrower_attribute_types bt ON (b.code = bt.code)
155 LEFT JOIN authorised_values a ON (a.category = bt.authorised_value_category AND a.authorised_value = b.attribute));
156 my $sth = $dbh->prepare($sql);
157 $sth->execute();
158 while (my $row = $sth->fetchrow_hashref) {
159 my $pattrs = $borrowernumber_to_attributes{$row->{bn}} ||= { };
160 push @{ $pattrs->{$row->{code}} }, [
161 $row->{val},
162 defined $row->{avdescription} ? $row->{avdescription} : $row->{val},
166 for my $bn (keys %borrowernumber_to_attributes) {
167 my $pattrs = $borrowernumber_to_attributes{$bn};
168 my $keep = 1;
169 for my $code (keys %cgi_attrcode_to_attrvalues) {
170 # discard patrons that do not match (case insensitive) at least one of each attribute filter value
171 my $discard = 1;
172 for my $attrval (map { lc $_ } @{ $cgi_attrcode_to_attrvalues{$code} }) {
173 ## if (grep { $attrval eq lc($_->[0]) } @{ $pattrs->{$code} })
174 if (grep { $attrval eq lc($_->[1]) } @{ $pattrs->{$code} }) {
175 $discard = 0;
176 last;
179 if ($discard) {
180 $keep = 0;
181 last;
184 if ($debug) {
185 my $showkeep = $keep ? 'keep' : 'do NOT keep';
186 print STDERR ">>> patron $bn: $showkeep attributes: ";
187 for (sort keys %$pattrs) { my @a=map { "$_->[0]/$_->[1] " } @{$pattrs->{$_}}; print STDERR "attrcode $_ = [@a] " }
188 print STDERR "\n";
190 delete $borrowernumber_to_attributes{$bn} if !$keep;
195 $template->param(
196 patron_attr_header_loop => [ map { { header => $_->{description} } } grep { ! $_->{isclone} } @patron_attr_filter_loop ],
197 filters => $filters,
198 borcatloop=> \@borcatloop,
199 itemtypeloop => \@itemtypeloop,
200 patron_attr_filter_loop => \@patron_attr_filter_loop,
201 showall => $showall,
204 if ($noreport) {
205 # la de dah ... page comes up presto-quicko
206 $template->param( noreport => $noreport );
207 } else {
208 # FIXME : the left joins + where clauses make the following SQL query really slow with large datasets :(
210 # FIX 1: use the table with the least rows as first in the join, second least second, etc
211 # ref: http://www.fiftyfoureleven.com/weblog/web-development/programming-and-scripts/mysql-optimization-tip
213 # FIX 2: ensure there are indexes for columns participating in the WHERE clauses, where feasible/reasonable
216 my $today_dt = dt_from_string();
217 $today_dt->truncate(to => 'minute');
218 my $todaysdate = $today_dt->strftime('%Y-%m-%d %H:%M');
220 $bornamefilter =~s/\*/\%/g;
221 $bornamefilter =~s/\?/\_/g;
223 my $strsth="SELECT date_due,
224 borrowers.title as borrowertitle,
225 borrowers.surname,
226 borrowers.firstname,
227 borrowers.streetnumber,
228 borrowers.streettype,
229 borrowers.address,
230 borrowers.address2,
231 borrowers.city,
232 borrowers.zipcode,
233 borrowers.country,
234 borrowers.phone,
235 borrowers.email,
236 borrowers.cardnumber,
237 borrowers.borrowernumber,
238 borrowers.branchcode,
239 issues.itemnumber,
240 issues.issuedate,
241 items.barcode,
242 items.homebranch,
243 items.holdingbranch,
244 biblio.title,
245 biblio.author,
246 biblio.biblionumber,
247 items.itemcallnumber,
248 items.replacementprice,
249 items.enumchron,
250 items.itemnotes_nonpublic,
251 items.itype
252 FROM issues
253 LEFT JOIN borrowers ON (issues.borrowernumber=borrowers.borrowernumber )
254 LEFT JOIN items ON (issues.itemnumber=items.itemnumber)
255 LEFT JOIN biblioitems ON (biblioitems.biblioitemnumber=items.biblioitemnumber)
256 LEFT JOIN biblio ON (biblio.biblionumber=items.biblionumber )
257 WHERE 1=1 "; # placeholder, since it is possible that none of the additional
258 # conditions will be selected by user
259 $strsth.=" AND date_due < '" . $todaysdate . "' " unless ($showall);
260 $strsth.=" AND (borrowers.firstname like '".$bornamefilter."%' or borrowers.surname like '".$bornamefilter."%' or borrowers.cardnumber like '".$bornamefilter."%')" if($bornamefilter) ;
261 $strsth.=" AND borrowers.categorycode = '" . $borcatfilter . "' " if $borcatfilter;
262 if( $itemtypefilter ){
263 if( C4::Context->preference('item-level_itypes') ){
264 $strsth.=" AND items.itype = '" . $itemtypefilter . "' ";
265 } else {
266 $strsth.=" AND biblioitems.itemtype = '" . $itemtypefilter . "' ";
269 if ( $borflagsfilter eq 'gonenoaddress' ) {
270 $strsth .= " AND borrowers.gonenoaddress <> 0";
272 elsif ( $borflagsfilter eq 'debarred' ) {
273 $strsth .= " AND borrowers.debarred >= CURDATE()" ;
275 elsif ( $borflagsfilter eq 'lost') {
276 $strsth .= " AND borrowers.lost <> 0";
278 $strsth.=" AND borrowers.branchcode = '" . $branchfilter . "' " if $branchfilter;
279 $strsth.=" AND items.homebranch = '" . $homebranchfilter . "' " if $homebranchfilter;
280 $strsth.=" AND items.holdingbranch = '" . $holdingbranchfilter . "' " if $holdingbranchfilter;
281 $strsth.=" AND date_due >= ?" if $dateduefrom;
282 $strsth.=" AND date_due <= ?" if $datedueto;
283 # restrict patrons (borrowers) to those matching the patron attribute filter(s), if any
284 my $bnlist = $have_pattr_filter_data ? join(',',keys %borrowernumber_to_attributes) : '';
285 $strsth =~ s/WHERE 1=1/WHERE 1=1 AND borrowers.borrowernumber IN ($bnlist)/ if $bnlist;
286 $strsth =~ s/WHERE 1=1/WHERE 0=1/ if $have_pattr_filter_data && !$bnlist; # no match if no borrowers matched patron attrs
287 $strsth.=" ORDER BY date_due, surname, firstname";
288 $template->param(sql=>$strsth);
289 my $sth=$dbh->prepare($strsth);
290 $sth->execute(
291 ($dateduefrom ? DateTime::Format::MySQL->format_datetime($dateduefrom) : ()),
292 ($datedueto ? DateTime::Format::MySQL->format_datetime($datedueto) : ()),
295 my @overduedata;
296 while (my $data = $sth->fetchrow_hashref) {
298 # most of the overdue report data is linked to the database schema, i.e. things like borrowernumber and phone
299 # but the patron attributes (patron_attr_value_loop) are unnormalised and varies dynamically from one db to the next
301 my $pattrs = $borrowernumber_to_attributes{$data->{borrowernumber}} || {}; # patron attrs for this borrower
302 # $pattrs is a hash { attrcode => [ [value,displayvalue], [value,displayvalue]... ] }
304 my @patron_attr_value_loop; # template array [ {value=>v1}, {value=>v2} ... } ]
305 for my $pattr_filter (grep { ! $_->{isclone} } @patron_attr_filter_loop) {
306 my @displayvalues = map { $_->[1] } @{ $pattrs->{$pattr_filter->{code}} }; # grab second value from each subarray
307 push @patron_attr_value_loop, { value => join(', ', sort { lc $a cmp lc $b } @displayvalues) };
310 push @overduedata, {
311 patron => Koha::Patrons->find( $data->{borrowernumber} ),
312 duedate => $data->{date_due},
313 borrowernumber => $data->{borrowernumber},
314 cardnumber => $data->{cardnumber},
315 borrowertitle => $data->{borrowertitle},
316 surname => $data->{surname},
317 firstname => $data->{firstname},
318 streetnumber => $data->{streetnumber},
319 streettype => $data->{streettype},
320 address => $data->{address},
321 address2 => $data->{address2},
322 city => $data->{city},
323 zipcode => $data->{zipcode},
324 country => $data->{country},
325 phone => $data->{phone},
326 email => $data->{email},
327 branchcode => $data->{branchcode},
328 barcode => $data->{barcode},
329 itemnum => $data->{itemnumber},
330 issuedate => output_pref({ dt => dt_from_string( $data->{issuedate} ), dateonly => 1 }),
331 biblionumber => $data->{biblionumber},
332 title => $data->{title},
333 author => $data->{author},
334 homebranchcode => $data->{homebranch},
335 holdingbranchcode => $data->{holdingbranch},
336 itemcallnumber => $data->{itemcallnumber},
337 replacementprice => $data->{replacementprice},
338 itemnotes_nonpublic => $data->{itemnotes_nonpublic},
339 enumchron => $data->{enumchron},
340 itemtype => $data->{itype},
341 patron_attr_value_loop => \@patron_attr_value_loop,
345 if ($op eq 'csv') {
346 binmode(STDOUT, ":encoding(UTF-8)");
347 my $csv = build_csv(\@overduedata);
348 print $input->header(-type => 'application/vnd.sun.xml.calc',
349 -encoding => 'utf-8',
350 -attachment=>"overdues.csv",
351 -filename=>"overdues.csv" );
352 print $csv;
353 exit;
356 # generate parameter list for CSV download link
357 my $new_cgi = CGI->new($input);
358 $new_cgi->delete('op');
360 $template->param(
361 todaysdate => output_pref($today_dt),
362 overdueloop => \@overduedata,
363 nnoverdue => scalar(@overduedata),
364 noverdue_is_plural => scalar(@overduedata) != 1,
365 noreport => $noreport,
366 isfiltered => $isfiltered,
367 borflag_gonenoaddress => $borflagsfilter eq 'gonenoaddress',
368 borflag_debarred => $borflagsfilter eq 'debarred',
369 borflag_lost => $borflagsfilter eq 'lost',
374 output_html_with_http_headers $input, $cookie, $template->output;
377 sub build_csv {
378 my $overdues = shift;
380 return "" if scalar(@$overdues) == 0;
382 my @lines = ();
384 # build header ...
385 my @keys =
386 qw ( duedate title author borrowertitle firstname surname phone barcode email address address2 zipcode city country
387 branchcode itemcallnumber biblionumber borrowernumber itemnum issuedate replacementprice itemnotes_nonpublic streetnumber streettype);
388 my $csv = Text::CSV_XS->new();
389 $csv->combine(@keys);
390 push @lines, $csv->string();
392 my @private_keys = qw( borrowertitle firstname surname phone email address address2 zipcode city country streetnumber streettype );
393 # ... and rest of report
394 foreach my $overdue ( @{ $overdues } ) {
395 unless ( $logged_in_user->can_see_patron_infos( $overdue->{patron} ) ) {
396 $overdue->{$_} = undef for @private_keys;
398 push @lines, $csv->string() if $csv->combine(map { $overdue->{$_} } @keys);
401 return join("\n", @lines) . "\n";