Bug 5830 Using XSLT on OPAC Lists page
[koha.git] / circ / overdue.pl
blobcad8e6d57138750115b3d04c00185daf10ceed68
1 #!/usr/bin/perl
4 # Copyright 2000-2002 Katipo Communications
6 # This file is part of Koha.
8 # Koha is free software; you can redistribute it and/or modify it under the
9 # terms of the GNU General Public License as published by the Free Software
10 # Foundation; either version 2 of the License, or (at your option) any later
11 # version.
13 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
14 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
15 # A PARTICULAR PURPOSE. See the GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License along
18 # with Koha; if not, write to the Free Software Foundation, Inc.,
19 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
21 use strict;
22 use warnings;
23 use C4::Context;
24 use C4::Output;
25 use CGI qw(-oldstyle_urls);
26 use C4::Auth;
27 use C4::Branch;
28 use C4::Debug;
29 use C4::Dates qw/format_date/;
30 use Date::Calc qw/Today/;
31 use Text::CSV_XS;
33 my $input = new CGI;
34 my $order = $input->param('order') || '';
35 my $showall = $input->param('showall');
36 my $bornamefilter = $input->param('borname') || '';
37 my $borcatfilter = $input->param('borcat') || '';
38 my $itemtypefilter = $input->param('itemtype') || '';
39 my $borflagsfilter = $input->param('borflag') || '';
40 my $branchfilter = $input->param('branch') || '';
41 my $op = $input->param('op') || '';
42 my $isfiltered = $op =~ /apply/i && $op =~ /filter/i;
43 my $noreport = C4::Context->preference('FilterBeforeOverdueReport') && ! $isfiltered && $op ne "csv";
45 my ( $template, $loggedinuser, $cookie ) = get_template_and_user(
47 template_name => "circ/overdue.tmpl",
48 query => $input,
49 type => "intranet",
50 authnotrequired => 0,
51 flagsrequired => { reports => 1, circulate => "circulate_remaining_permissions" },
52 debug => 1,
56 my $dbh = C4::Context->dbh;
58 my $req;
59 $req = $dbh->prepare( "select categorycode, description from categories order by description");
60 $req->execute;
61 my @borcatloop;
62 while (my ($catcode, $description) =$req->fetchrow) {
63 push @borcatloop, {
64 value => $catcode,
65 selected => $catcode eq $borcatfilter ? 1 : 0,
66 catname => $description,
70 $req = $dbh->prepare( "select itemtype, description from itemtypes order by description");
71 $req->execute;
72 my @itemtypeloop;
73 while (my ($itemtype, $description) =$req->fetchrow) {
74 push @itemtypeloop, {
75 value => $itemtype,
76 selected => $itemtype eq $itemtypefilter ? 1 : 0,
77 itemtypename => $description,
80 my $onlymine=C4::Context->preference('IndependantBranches') &&
81 C4::Context->userenv &&
82 C4::Context->userenv->{flags} % 2 !=1 &&
83 C4::Context->userenv->{branch};
85 $branchfilter = C4::Context->userenv->{'branch'} if ($onlymine && !$branchfilter);
87 # Filtering by Patron Attributes
88 # @patron_attr_filter_loop is non empty if there are any patron attribute filters
89 # %cgi_attrcode_to_attrvalues contains the patron attribute filter values, as returned by the CGI
90 # %borrowernumber_to_attributes is populated by those borrowernumbers matching the patron attribute filters
92 my %cgi_attrcode_to_attrvalues; # ( patron_attribute_code => [ zero or more attribute filter values from the CGI ] )
93 for my $attrcode (grep { /^patron_attr_filter_/ } $input->param) {
94 if (my @attrvalues = grep { length($_) > 0 } $input->param($attrcode)) {
95 $attrcode =~ s/^patron_attr_filter_//;
96 $cgi_attrcode_to_attrvalues{$attrcode} = \@attrvalues;
97 print STDERR ">>>param($attrcode)[@{[scalar @attrvalues]}] = '@attrvalues'\n" if $debug;
100 my $have_pattr_filter_data = keys(%cgi_attrcode_to_attrvalues) > 0;
102 my @patron_attr_filter_loop; # array of [ domid cgivalue ismany isclone ordinal code description repeatable authorised_value_category ]
103 my @patron_attr_order_loop; # array of { label => $patron_attr_label, value => $patron_attr_order }
105 my @sort_roots = qw(borrower title barcode date_due);
106 push @sort_roots, map {$_ . " desc"} @sort_roots;
107 my @order_loop = ({selected => $order ? 0 : 1}); # initial blank row
108 foreach (@sort_roots) {
109 my $tmpl_name = $_;
110 $tmpl_name =~ s/\s/_/g;
111 push @order_loop, {
112 selected => $order eq $_ ? 1 : 0,
113 ordervalue => $_,
114 'order_' . $tmpl_name => 1,
118 my $sth = $dbh->prepare('SELECT code,description,repeatable,authorised_value_category
119 FROM borrower_attribute_types
120 WHERE staff_searchable <> 0
121 ORDER BY description');
122 $sth->execute();
123 my $ordinal = 0;
124 while (my $row = $sth->fetchrow_hashref) {
125 $row->{ordinal} = $ordinal;
126 my $code = $row->{code};
127 my $cgivalues = $cgi_attrcode_to_attrvalues{$code} || [ '' ];
128 my $isclone = 0;
129 $row->{ismany} = @$cgivalues > 1;
130 my $serial = 0;
131 for (@$cgivalues) {
132 $row->{domid} = $ordinal * 1000 + $serial;
133 $row->{cgivalue} = $_;
134 $row->{isclone} = $isclone;
135 push @patron_attr_filter_loop, { %$row }; # careful: must store a *deep copy* of the modified row
136 } continue { $isclone = 1, ++$serial }
137 foreach my $sortorder ('asc', 'desc') {
138 my $ordervalue = "patron_attr_${sortorder}_${code}";
139 push @order_loop, {
140 selected => $order eq $ordervalue ? 1 : 0,
141 ordervalue => $ordervalue,
142 label => $row->{description},
143 $sortorder => 1,
146 } continue { ++$ordinal }
147 for (@patron_attr_order_loop) { $_->{selected} = 1 if $order eq $_->{value} }
149 $template->param(ORDER_LOOP => \@order_loop);
151 my %borrowernumber_to_attributes; # hash of { borrowernumber => { attrcode => [ [val,display], [val,display], ... ] } }
152 # i.e. val differs from display when attr is an authorised value
153 if (@patron_attr_filter_loop) {
154 # MAYBE FIXME: currently, *all* borrower_attributes are loaded into %borrowernumber_to_attributes
155 # then filtered and honed down to match the patron attribute filters. If this is
156 # too resource intensive, MySQL can be used to do the filtering, i.e. rewire the
157 # SQL below to select only those attribute values that match the filters.
159 my $sql = q(SELECT borrowernumber AS bn, b.code, attribute AS val, category AS avcategory, lib AS avdescription
160 FROM borrower_attributes b
161 JOIN borrower_attribute_types bt ON (b.code = bt.code)
162 LEFT JOIN authorised_values a ON (a.category = bt.authorised_value_category AND a.authorised_value = b.attribute));
163 my $sth = $dbh->prepare($sql);
164 $sth->execute();
165 while (my $row = $sth->fetchrow_hashref) {
166 my $pattrs = $borrowernumber_to_attributes{$row->{bn}} ||= { };
167 push @{ $pattrs->{$row->{code}} }, [
168 $row->{val},
169 defined $row->{avdescription} ? $row->{avdescription} : $row->{val},
173 for my $bn (keys %borrowernumber_to_attributes) {
174 my $pattrs = $borrowernumber_to_attributes{$bn};
175 my $keep = 1;
176 for my $code (keys %cgi_attrcode_to_attrvalues) {
177 # discard patrons that do not match (case insensitive) at least one of each attribute filter value
178 my $discard = 1;
179 for my $attrval (map { lc $_ } @{ $cgi_attrcode_to_attrvalues{$code} }) {
180 ## if (grep { $attrval eq lc($_->[0]) } @{ $pattrs->{$code} })
181 if (grep { $attrval eq lc($_->[1]) } @{ $pattrs->{$code} }) {
182 $discard = 0;
183 last;
186 if ($discard) {
187 $keep = 0;
188 last;
191 if ($debug) {
192 my $showkeep = $keep ? 'keep' : 'do NOT keep';
193 print STDERR ">>> patron $bn: $showkeep attributes: ";
194 for (sort keys %$pattrs) { my @a=map { "$_->[0]/$_->[1] " } @{$pattrs->{$_}}; print STDERR "attrcode $_ = [@a] " }
195 print STDERR "\n";
197 delete $borrowernumber_to_attributes{$bn} if !$keep;
202 $template->param(
203 patron_attr_header_loop => [ map { { header => $_->{description} } } grep { ! $_->{isclone} } @patron_attr_filter_loop ],
204 branchloop => GetBranchesLoop($branchfilter, $onlymine),
205 branchfilter => $branchfilter,
206 borcatloop=> \@borcatloop,
207 itemtypeloop => \@itemtypeloop,
208 patron_attr_filter_loop => \@patron_attr_filter_loop,
209 borname => $bornamefilter,
210 order => $order,
211 showall => $showall);
213 if ($noreport) {
214 # la de dah ... page comes up presto-quicko
215 $template->param( noreport => $noreport );
216 } else {
217 # FIXME : the left joins + where clauses make the following SQL query really slow with large datasets :(
219 # FIX 1: use the table with the least rows as first in the join, second least second, etc
220 # ref: http://www.fiftyfoureleven.com/weblog/web-development/programming-and-scripts/mysql-optimization-tip
222 # FIX 2: ensure there are indexes for columns participating in the WHERE clauses, where feasible/reasonable
225 my $todaysdate = sprintf("%-04.4d-%-02.2d-%02.2d", Today());
227 $bornamefilter =~s/\*/\%/g;
228 $bornamefilter =~s/\?/\_/g;
230 my $strsth="SELECT date_due,
231 concat(surname,' ', firstname) as borrower,
232 borrowers.phone,
233 borrowers.email,
234 issues.itemnumber,
235 items.barcode,
236 biblio.title,
237 biblio.author,
238 borrowers.borrowernumber,
239 biblio.biblionumber,
240 borrowers.branchcode,
241 items.itemcallnumber,
242 items.replacementprice
243 FROM issues
244 LEFT JOIN borrowers ON (issues.borrowernumber=borrowers.borrowernumber )
245 LEFT JOIN items ON (issues.itemnumber=items.itemnumber)
246 LEFT JOIN biblioitems ON (biblioitems.biblioitemnumber=items.biblioitemnumber)
247 LEFT JOIN biblio ON (biblio.biblionumber=items.biblionumber )
248 WHERE 1=1 "; # placeholder, since it is possible that none of the additional
249 # conditions will be selected by user
250 $strsth.=" AND date_due < '" . $todaysdate . "' " unless ($showall);
251 $strsth.=" AND (borrowers.firstname like '".$bornamefilter."%' or borrowers.surname like '".$bornamefilter."%' or borrowers.cardnumber like '".$bornamefilter."%')" if($bornamefilter) ;
252 $strsth.=" AND borrowers.categorycode = '" . $borcatfilter . "' " if $borcatfilter;
253 $strsth.=" AND biblioitems.itemtype = '" . $itemtypefilter . "' " if $itemtypefilter;
254 $strsth.=" AND borrowers.flags = '" . $borflagsfilter . "' " if $borflagsfilter;
255 $strsth.=" AND borrowers.branchcode = '" . $branchfilter . "' " if $branchfilter;
256 # restrict patrons (borrowers) to those matching the patron attribute filter(s), if any
257 my $bnlist = $have_pattr_filter_data ? join(',',keys %borrowernumber_to_attributes) : '';
258 $strsth =~ s/WHERE 1=1/WHERE 1=1 AND borrowers.borrowernumber IN ($bnlist)/ if $bnlist;
259 $strsth =~ s/WHERE 1=1/WHERE 0=1/ if $have_pattr_filter_data && !$bnlist; # no match if no borrowers matched patron attrs
260 $strsth.=" ORDER BY " . (
261 ($order eq "borrower" or $order eq "borrower desc") ? "$order, date_due" :
262 ($order eq "title" or $order eq "title desc") ? "$order, date_due, borrower" :
263 ($order eq "barcode" or $order eq "barcode desc") ? "items.$order, date_due, borrower" :
264 ($order eq "date_due desc") ? "date_due DESC, borrower" :
265 "date_due, borrower" # default sort order
267 $template->param(sql=>$strsth);
268 my $sth=$dbh->prepare($strsth);
269 #warn "overdue.pl : query string ".$strsth;
270 $sth->execute();
272 my @overduedata;
273 while (my $data = $sth->fetchrow_hashref) {
275 # most of the overdue report data is linked to the database schema, i.e. things like borrowernumber and phone
276 # but the patron attributes (patron_attr_value_loop) are unnormalised and varies dynamically from one db to the next
278 my $pattrs = $borrowernumber_to_attributes{$data->{borrowernumber}} || {}; # patron attrs for this borrower
279 # $pattrs is a hash { attrcode => [ [value,displayvalue], [value,displayvalue]... ] }
281 my @patron_attr_value_loop; # template array [ {value=>v1}, {value=>v2} ... } ]
282 for my $pattr_filter (grep { ! $_->{isclone} } @patron_attr_filter_loop) {
283 my @displayvalues = map { $_->[1] } @{ $pattrs->{$pattr_filter->{code}} }; # grab second value from each subarray
284 push @patron_attr_value_loop, { value => join(', ', sort { lc $a cmp lc $b } @displayvalues) };
287 push @overduedata, {
288 duedate => format_date($data->{date_due}),
289 borrowernumber => $data->{borrowernumber},
290 barcode => $data->{barcode},
291 itemnum => $data->{itemnumber},
292 name => $data->{borrower},
293 phone => $data->{phone},
294 email => $data->{email},
295 biblionumber => $data->{biblionumber},
296 title => $data->{title},
297 author => $data->{author},
298 branchcode => $data->{branchcode},
299 itemcallnumber => $data->{itemcallnumber},
300 replacementprice => $data->{replacementprice},
301 patron_attr_value_loop => \@patron_attr_value_loop,
305 my ($attrorder) = $order =~ /patron_attr_(.*)$/;
306 my $patrorder = '';
307 my $sortorder = 'asc';
308 if (defined $attrorder) {
309 ($sortorder, $patrorder) = split /_/, $attrorder, 2;
311 print STDERR ">>> order is $order, patrorder is $patrorder, sortorder is $sortorder\n" if $debug;
313 if (my @attrtype = grep { $_->{'code'} eq $patrorder } @patron_attr_filter_loop) { # sort by patron attrs perhaps?
314 my $ordinal = $attrtype[0]{ordinal};
315 print STDERR ">>> sort ordinal is $ordinal\n" if $debug;
317 sub patronattr_sorter_asc {
318 lc $a->{patron_attr_value_loop}[$ordinal]{value}
320 lc $b->{patron_attr_value_loop}[$ordinal]{value} }
322 sub patronattr_sorter_des { -patronattr_sorter_asc() }
324 my $sorter = $sortorder eq 'desc' ? \&patronattr_sorter_des : \&patronattr_sorter_asc;
325 @overduedata = sort $sorter @overduedata;
328 if ($op eq 'csv') {
329 binmode(STDOUT, ":utf8");
330 my $csv = build_csv(\@overduedata);
331 print $input->header(-type => 'application/vnd.sun.xml.calc',
332 -encoding => 'utf-8',
333 -attachment=>"overdues.csv",
334 -filename=>"overdues.csv" );
335 print $csv;
336 exit;
339 # generate parameter list for CSV download link
340 my $new_cgi = CGI->new($input);
341 $new_cgi->delete('op');
342 my $csv_param_string = $new_cgi->query_string();
344 $template->param(
345 csv_param_string => $csv_param_string,
346 todaysdate => format_date($todaysdate),
347 overdueloop => \@overduedata,
348 nnoverdue => scalar(@overduedata),
349 noverdue_is_plural => scalar(@overduedata) != 1,
350 noreport => $noreport,
351 isfiltered => $isfiltered,
352 borflag_gonenoaddress => $borflagsfilter eq 'gonenoaddress',
353 borflag_debarred => $borflagsfilter eq 'debarred',
354 borflag_lost => $borflagsfilter eq 'lost',
359 output_html_with_http_headers $input, $cookie, $template->output;
362 sub build_csv {
363 my $overdues = shift;
365 return "" if scalar(@$overdues) == 0;
367 my @lines = ();
369 # build header ...
370 my @keys = grep { $_ ne 'patron_attr_value_loop' } sort keys %{ $overdues->[0] };
371 my $csv = Text::CSV_XS->new();
372 $csv->combine(@keys);
373 push @lines, $csv->string();
375 # ... and rest of report
376 foreach my $overdue ( @{ $overdues } ) {
377 push @lines, $csv->string() if $csv->combine(map { $overdue->{$_} } @keys);
380 return join("\n", @lines) . "\n";