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