Bug 14168 - enhance streaming cataloging to include youtube
[koha.git] / circ / overdue.pl
blob4fb046fb8ef224a6d422604b605ca1301758aa82
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::Branch;
28 use C4::Debug;
29 use Text::CSV_XS;
30 use Koha::DateUtils;
31 use DateTime;
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 $homebranchfilter = $input->param('homebranch') || '';
42 my $holdingbranchfilter = $input->param('holdingbranch') || '';
43 my $op = $input->param('op') || '';
45 my ($dateduefrom, $datedueto);
46 if ( $dateduefrom = $input->param('dateduefrom') ) {
47 $dateduefrom = dt_from_string( $dateduefrom );
49 if ( $datedueto = $input->param('datedueto') ) {
50 $datedueto = dt_from_string( $datedueto )->set_hour(23)->set_minute(59);
53 my $isfiltered = $op =~ /apply/i && $op =~ /filter/i;
54 my $noreport = C4::Context->preference('FilterBeforeOverdueReport') && ! $isfiltered && $op ne "csv";
56 my ( $template, $loggedinuser, $cookie ) = get_template_and_user(
58 template_name => "circ/overdue.tt",
59 query => $input,
60 type => "intranet",
61 authnotrequired => 0,
62 flagsrequired => { circulate => "overdues_report" },
63 debug => 1,
67 my $dbh = C4::Context->dbh;
69 my $req;
70 $req = $dbh->prepare( "select categorycode, description from categories order by description");
71 $req->execute;
72 my @borcatloop;
73 while (my ($catcode, $description) =$req->fetchrow) {
74 push @borcatloop, {
75 value => $catcode,
76 selected => $catcode eq $borcatfilter ? 1 : 0,
77 catname => $description,
81 $req = $dbh->prepare( "select itemtype, description from itemtypes order by description");
82 $req->execute;
83 my @itemtypeloop;
84 while (my ($itemtype, $description) =$req->fetchrow) {
85 push @itemtypeloop, {
86 value => $itemtype,
87 selected => $itemtype eq $itemtypefilter ? 1 : 0,
88 itemtypename => $description,
91 my $onlymine =
92 C4::Context->preference('IndependentBranches')
93 && C4::Context->userenv
94 && !C4::Context->IsSuperLibrarian()
95 && C4::Context->userenv->{branch};
97 $branchfilter = C4::Context->userenv->{'branch'} if ($onlymine && !$branchfilter);
99 # Filtering by Patron Attributes
100 # @patron_attr_filter_loop is non empty if there are any patron attribute filters
101 # %cgi_attrcode_to_attrvalues contains the patron attribute filter values, as returned by the CGI
102 # %borrowernumber_to_attributes is populated by those borrowernumbers matching the patron attribute filters
104 my %cgi_attrcode_to_attrvalues; # ( patron_attribute_code => [ zero or more attribute filter values from the CGI ] )
105 for my $attrcode (grep { /^patron_attr_filter_/ } $input->param) {
106 if (my @attrvalues = grep { length($_) > 0 } $input->param($attrcode)) {
107 $attrcode =~ s/^patron_attr_filter_//;
108 $cgi_attrcode_to_attrvalues{$attrcode} = \@attrvalues;
109 print STDERR ">>>param($attrcode)[@{[scalar @attrvalues]}] = '@attrvalues'\n" if $debug;
112 my $have_pattr_filter_data = keys(%cgi_attrcode_to_attrvalues) > 0;
114 my @patron_attr_filter_loop; # array of [ domid cgivalue ismany isclone ordinal code description repeatable authorised_value_category ]
115 my @patron_attr_order_loop; # array of { label => $patron_attr_label, value => $patron_attr_order }
117 my @sort_roots = qw(borrower title barcode date_due);
118 push @sort_roots, map {$_ . " desc"} @sort_roots;
119 my @order_loop = ({selected => $order ? 0 : 1}); # initial blank row
120 foreach (@sort_roots) {
121 my $tmpl_name = $_;
122 $tmpl_name =~ s/\s/_/g;
123 push @order_loop, {
124 selected => $order eq $_ ? 1 : 0,
125 ordervalue => $_,
126 'order_' . $tmpl_name => 1,
130 my $sth = $dbh->prepare('SELECT code,description,repeatable,authorised_value_category
131 FROM borrower_attribute_types
132 WHERE staff_searchable <> 0
133 ORDER BY description');
134 $sth->execute();
135 my $ordinal = 0;
136 while (my $row = $sth->fetchrow_hashref) {
137 $row->{ordinal} = $ordinal;
138 my $code = $row->{code};
139 my $cgivalues = $cgi_attrcode_to_attrvalues{$code} || [ '' ];
140 my $isclone = 0;
141 $row->{ismany} = @$cgivalues > 1;
142 my $serial = 0;
143 for (@$cgivalues) {
144 $row->{domid} = $ordinal * 1000 + $serial;
145 $row->{cgivalue} = $_;
146 $row->{isclone} = $isclone;
147 push @patron_attr_filter_loop, { %$row }; # careful: must store a *deep copy* of the modified row
148 } continue { $isclone = 1, ++$serial }
149 foreach my $sortorder ('asc', 'desc') {
150 my $ordervalue = "patron_attr_${sortorder}_${code}";
151 push @order_loop, {
152 selected => $order eq $ordervalue ? 1 : 0,
153 ordervalue => $ordervalue,
154 label => $row->{description},
155 $sortorder => 1,
158 } continue { ++$ordinal }
159 for (@patron_attr_order_loop) { $_->{selected} = 1 if $order eq $_->{value} }
161 $template->param(ORDER_LOOP => \@order_loop);
163 my %borrowernumber_to_attributes; # hash of { borrowernumber => { attrcode => [ [val,display], [val,display], ... ] } }
164 # i.e. val differs from display when attr is an authorised value
165 if (@patron_attr_filter_loop) {
166 # MAYBE FIXME: currently, *all* borrower_attributes are loaded into %borrowernumber_to_attributes
167 # then filtered and honed down to match the patron attribute filters. If this is
168 # too resource intensive, MySQL can be used to do the filtering, i.e. rewire the
169 # SQL below to select only those attribute values that match the filters.
171 my $sql = q(SELECT borrowernumber AS bn, b.code, attribute AS val, category AS avcategory, lib AS avdescription
172 FROM borrower_attributes b
173 JOIN borrower_attribute_types bt ON (b.code = bt.code)
174 LEFT JOIN authorised_values a ON (a.category = bt.authorised_value_category AND a.authorised_value = b.attribute));
175 my $sth = $dbh->prepare($sql);
176 $sth->execute();
177 while (my $row = $sth->fetchrow_hashref) {
178 my $pattrs = $borrowernumber_to_attributes{$row->{bn}} ||= { };
179 push @{ $pattrs->{$row->{code}} }, [
180 $row->{val},
181 defined $row->{avdescription} ? $row->{avdescription} : $row->{val},
185 for my $bn (keys %borrowernumber_to_attributes) {
186 my $pattrs = $borrowernumber_to_attributes{$bn};
187 my $keep = 1;
188 for my $code (keys %cgi_attrcode_to_attrvalues) {
189 # discard patrons that do not match (case insensitive) at least one of each attribute filter value
190 my $discard = 1;
191 for my $attrval (map { lc $_ } @{ $cgi_attrcode_to_attrvalues{$code} }) {
192 ## if (grep { $attrval eq lc($_->[0]) } @{ $pattrs->{$code} })
193 if (grep { $attrval eq lc($_->[1]) } @{ $pattrs->{$code} }) {
194 $discard = 0;
195 last;
198 if ($discard) {
199 $keep = 0;
200 last;
203 if ($debug) {
204 my $showkeep = $keep ? 'keep' : 'do NOT keep';
205 print STDERR ">>> patron $bn: $showkeep attributes: ";
206 for (sort keys %$pattrs) { my @a=map { "$_->[0]/$_->[1] " } @{$pattrs->{$_}}; print STDERR "attrcode $_ = [@a] " }
207 print STDERR "\n";
209 delete $borrowernumber_to_attributes{$bn} if !$keep;
214 $template->param(
215 patron_attr_header_loop => [ map { { header => $_->{description} } } grep { ! $_->{isclone} } @patron_attr_filter_loop ],
216 branchloop => GetBranchesLoop($branchfilter, $onlymine),
217 homebranchloop => GetBranchesLoop( $homebranchfilter, $onlymine ),
218 holdingbranchloop => GetBranchesLoop( $holdingbranchfilter, $onlymine ),
219 branchfilter => $branchfilter,
220 homebranchfilter => $homebranchfilter,
221 holdingbranchfilter => $homebranchfilter,
222 borcatloop=> \@borcatloop,
223 itemtypeloop => \@itemtypeloop,
224 patron_attr_filter_loop => \@patron_attr_filter_loop,
225 borname => $bornamefilter,
226 order => $order,
227 showall => $showall,
228 dateduefrom => $dateduefrom,
229 datedueto => $datedueto,
232 if ($noreport) {
233 # la de dah ... page comes up presto-quicko
234 $template->param( noreport => $noreport );
235 } else {
236 # FIXME : the left joins + where clauses make the following SQL query really slow with large datasets :(
238 # FIX 1: use the table with the least rows as first in the join, second least second, etc
239 # ref: http://www.fiftyfoureleven.com/weblog/web-development/programming-and-scripts/mysql-optimization-tip
241 # FIX 2: ensure there are indexes for columns participating in the WHERE clauses, where feasible/reasonable
244 my $today_dt = DateTime->now(time_zone => C4::Context->tz);
245 $today_dt->truncate(to => 'minute');
246 my $todaysdate = $today_dt->strftime('%Y-%m-%d %H:%M');
248 $bornamefilter =~s/\*/\%/g;
249 $bornamefilter =~s/\?/\_/g;
251 my $strsth="SELECT date_due,
252 borrowers.title as borrowertitle,
253 borrowers.surname,
254 borrowers.firstname,
255 borrowers.streetnumber,
256 borrowers.streettype,
257 borrowers.address,
258 borrowers.address2,
259 borrowers.city,
260 borrowers.zipcode,
261 borrowers.country,
262 borrowers.phone,
263 borrowers.email,
264 borrowers.cardnumber,
265 issues.itemnumber,
266 issues.issuedate,
267 items.barcode,
268 items.homebranch,
269 items.holdingbranch,
270 biblio.title,
271 biblio.author,
272 borrowers.borrowernumber,
273 biblio.biblionumber,
274 borrowers.branchcode,
275 items.itemcallnumber,
276 items.replacementprice,
277 items.enumchron
278 FROM issues
279 LEFT JOIN borrowers ON (issues.borrowernumber=borrowers.borrowernumber )
280 LEFT JOIN items ON (issues.itemnumber=items.itemnumber)
281 LEFT JOIN biblioitems ON (biblioitems.biblioitemnumber=items.biblioitemnumber)
282 LEFT JOIN biblio ON (biblio.biblionumber=items.biblionumber )
283 WHERE 1=1 "; # placeholder, since it is possible that none of the additional
284 # conditions will be selected by user
285 $strsth.=" AND date_due < '" . $todaysdate . "' " unless ($showall);
286 $strsth.=" AND (borrowers.firstname like '".$bornamefilter."%' or borrowers.surname like '".$bornamefilter."%' or borrowers.cardnumber like '".$bornamefilter."%')" if($bornamefilter) ;
287 $strsth.=" AND borrowers.categorycode = '" . $borcatfilter . "' " if $borcatfilter;
288 if( $itemtypefilter ){
289 if( C4::Context->preference('item-level_itypes') ){
290 $strsth.=" AND items.itype = '" . $itemtypefilter . "' ";
291 } else {
292 $strsth.=" AND biblioitems.itemtype = '" . $itemtypefilter . "' ";
295 if ( $borflagsfilter eq 'gonenoaddress' ) {
296 $strsth .= " AND borrowers.gonenoaddress <> 0";
298 elsif ( $borflagsfilter eq 'debarred' ) {
299 $strsth .= " AND borrowers.debarred >= CURDATE()" ;
301 elsif ( $borflagsfilter eq 'lost') {
302 $strsth .= " AND borrowers.lost <> 0";
304 $strsth.=" AND borrowers.branchcode = '" . $branchfilter . "' " if $branchfilter;
305 $strsth.=" AND items.homebranch = '" . $homebranchfilter . "' " if $homebranchfilter;
306 $strsth.=" AND items.holdingbranch = '" . $holdingbranchfilter . "' " if $holdingbranchfilter;
307 $strsth.=" AND date_due >= ?" if $dateduefrom;
308 $strsth.=" AND date_due <= ?" if $datedueto;
309 # restrict patrons (borrowers) to those matching the patron attribute filter(s), if any
310 my $bnlist = $have_pattr_filter_data ? join(',',keys %borrowernumber_to_attributes) : '';
311 $strsth =~ s/WHERE 1=1/WHERE 1=1 AND borrowers.borrowernumber IN ($bnlist)/ if $bnlist;
312 $strsth =~ s/WHERE 1=1/WHERE 0=1/ if $have_pattr_filter_data && !$bnlist; # no match if no borrowers matched patron attrs
313 $strsth.=" ORDER BY " . (
314 ($order eq "borrower") ? "surname, firstname, date_due" :
315 ($order eq "borrower desc") ? "surname desc, firstname desc, date_due" :
316 ($order eq "title" or $order eq "title desc") ? "$order, date_due, surname, firstname" :
317 ($order eq "barcode" or $order eq "barcode desc") ? "items.$order, date_due, surname, firstname" :
318 ($order eq "date_due desc") ? "date_due DESC, surname, firstname" :
319 "date_due, surname, firstname" # default sort order
321 $template->param(sql=>$strsth);
322 my $sth=$dbh->prepare($strsth);
323 $sth->execute(
324 ($dateduefrom ? output_pref({ dt => $dateduefrom, dateformat => 'iso' }) : ()),
325 ($datedueto ? output_pref({ dt => $datedueto, dateformat => 'iso' }) : ()),
328 my @overduedata;
329 while (my $data = $sth->fetchrow_hashref) {
331 # most of the overdue report data is linked to the database schema, i.e. things like borrowernumber and phone
332 # but the patron attributes (patron_attr_value_loop) are unnormalised and varies dynamically from one db to the next
334 my $pattrs = $borrowernumber_to_attributes{$data->{borrowernumber}} || {}; # patron attrs for this borrower
335 # $pattrs is a hash { attrcode => [ [value,displayvalue], [value,displayvalue]... ] }
337 my @patron_attr_value_loop; # template array [ {value=>v1}, {value=>v2} ... } ]
338 for my $pattr_filter (grep { ! $_->{isclone} } @patron_attr_filter_loop) {
339 my @displayvalues = map { $_->[1] } @{ $pattrs->{$pattr_filter->{code}} }; # grab second value from each subarray
340 push @patron_attr_value_loop, { value => join(', ', sort { lc $a cmp lc $b } @displayvalues) };
342 my $dt = dt_from_string($data->{date_due}, 'sql');
344 push @overduedata, {
345 duedate => output_pref($dt),
346 borrowernumber => $data->{borrowernumber},
347 barcode => $data->{barcode},
348 cardnumber => $data->{cardnumber},
349 itemnum => $data->{itemnumber},
350 issuedate => output_pref({ dt => dt_from_string( $data->{issuedate} ), dateonly => 1 }),
351 borrowertitle => $data->{borrowertitle},
352 surname => $data->{surname},
353 firstname => $data->{firstname},
354 streetnumber => $data->{streetnumber},
355 streettype => $data->{streettype},
356 address => $data->{address},
357 address2 => $data->{address2},
358 city => $data->{city},
359 zipcode => $data->{zipcode},
360 country => $data->{country},
361 phone => $data->{phone},
362 email => $data->{email},
363 biblionumber => $data->{biblionumber},
364 title => $data->{title},
365 author => $data->{author},
366 branchcode => $data->{branchcode},
367 homebranchcode => $data->{homebranchcode},
368 holdingbranchcode => $data->{holdingbranchcode},
369 itemcallnumber => $data->{itemcallnumber},
370 replacementprice => $data->{replacementprice},
371 enumchron => $data->{enumchron},
372 patron_attr_value_loop => \@patron_attr_value_loop,
376 my ($attrorder) = $order =~ /patron_attr_(.*)$/;
377 my $patrorder = '';
378 my $sortorder = 'asc';
379 if (defined $attrorder) {
380 ($sortorder, $patrorder) = split /_/, $attrorder, 2;
382 print STDERR ">>> order is $order, patrorder is $patrorder, sortorder is $sortorder\n" if $debug;
384 if (my @attrtype = grep { $_->{'code'} eq $patrorder } @patron_attr_filter_loop) { # sort by patron attrs perhaps?
385 my $ordinal = $attrtype[0]{ordinal};
386 print STDERR ">>> sort ordinal is $ordinal\n" if $debug;
388 sub patronattr_sorter_asc {
389 lc $a->{patron_attr_value_loop}[$ordinal]{value}
391 lc $b->{patron_attr_value_loop}[$ordinal]{value} }
393 sub patronattr_sorter_des { -patronattr_sorter_asc() }
395 my $sorter = $sortorder eq 'desc' ? \&patronattr_sorter_des : \&patronattr_sorter_asc;
396 @overduedata = sort $sorter @overduedata;
399 if ($op eq 'csv') {
400 binmode(STDOUT, ":encoding(UTF-8)");
401 my $csv = build_csv(\@overduedata);
402 print $input->header(-type => 'application/vnd.sun.xml.calc',
403 -encoding => 'utf-8',
404 -attachment=>"overdues.csv",
405 -filename=>"overdues.csv" );
406 print $csv;
407 exit;
410 # generate parameter list for CSV download link
411 my $new_cgi = CGI->new($input);
412 $new_cgi->delete('op');
413 my $csv_param_string = $new_cgi->query_string();
415 $template->param(
416 csv_param_string => $csv_param_string,
417 todaysdate => output_pref($today_dt),
418 overdueloop => \@overduedata,
419 nnoverdue => scalar(@overduedata),
420 noverdue_is_plural => scalar(@overduedata) != 1,
421 noreport => $noreport,
422 isfiltered => $isfiltered,
423 borflag_gonenoaddress => $borflagsfilter eq 'gonenoaddress',
424 borflag_debarred => $borflagsfilter eq 'debarred',
425 borflag_lost => $borflagsfilter eq 'lost',
430 output_html_with_http_headers $input, $cookie, $template->output;
433 sub build_csv {
434 my $overdues = shift;
436 return "" if scalar(@$overdues) == 0;
438 my @lines = ();
440 # build header ...
441 my @keys = qw /duedate title author borrowertitle firstname surname phone barcode email address address2 zipcode city country
442 branchcode itemcallnumber biblionumber borrowernumber itemnum issuedate replacementprice streetnumber streettype/;
443 my $csv = Text::CSV_XS->new();
444 $csv->combine(@keys);
445 push @lines, $csv->string();
447 # ... and rest of report
448 foreach my $overdue ( @{ $overdues } ) {
449 push @lines, $csv->string() if $csv->combine(map { $overdue->{$_} } @keys);
452 return join("\n", @lines) . "\n";