Fix FSF address in directory circ/
[wip/koha-chris_n.git] / circ / overdue.pl
1 #!/usr/bin/perl
2
3
4 # Copyright 2000-2002 Katipo Communications
5 #
6 # This file is part of Koha.
7 #
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.
12 #
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.
16 #
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.
20
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;
32
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";
44
45 my ( $template, $loggedinuser, $cookie ) = get_template_and_user(
46     {
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,
53     }
54 );
55
56 my $dbh = C4::Context->dbh;
57
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,
67     };
68 }
69
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,
78     };
79 }
80 my $onlymine=C4::Context->preference('IndependantBranches') && 
81              C4::Context->userenv &&
82              C4::Context->userenv->{flags} % 2 !=1 &&
83              C4::Context->userenv->{branch};
84
85 $branchfilter = C4::Context->userenv->{'branch'} if ($onlymine && !$branchfilter);
86
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
91
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;
98     }
99 }
100 my $have_pattr_filter_data = keys(%cgi_attrcode_to_attrvalues) > 0;
101
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 }
104
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,
115     };
116 }
117
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,
144         };
145     }
146 } continue { ++$ordinal }
147 for (@patron_attr_order_loop) { $_->{selected} = 1 if $order eq $_->{value} }
148
149 $template->param(ORDER_LOOP => \@order_loop);
150
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.
158
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},
170         ];
171     }
172
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;
184                 }
185             }
186             if ($discard) {
187                 $keep = 0;
188                 last;
189             }
190         }
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";
196         }
197         delete $borrowernumber_to_attributes{$bn} if !$keep;
198     }
199 }
200
201
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);
212
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 :(
218     #
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
221     #
222     #  FIX 2: ensure there are indexes for columns participating in the WHERE clauses, where feasible/reasonable
223
224
225     my $todaysdate = sprintf("%-04.4d-%-02.2d-%02.2d", Today());
226
227     $bornamefilter =~s/\*/\%/g;
228     $bornamefilter =~s/\?/\_/g;
229
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
266     );
267     $template->param(sql=>$strsth);
268     my $sth=$dbh->prepare($strsth);
269     #warn "overdue.pl : query string ".$strsth;
270     $sth->execute();
271
272     my @overduedata;
273     while (my $data = $sth->fetchrow_hashref) {
274
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
277
278         my $pattrs = $borrowernumber_to_attributes{$data->{borrowernumber}} || {};  # patron attrs for this borrower
279         # $pattrs is a hash { attrcode => [  [value,displayvalue], [value,displayvalue]... ] }
280
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) };
285         }
286
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,
302         };
303     }
304
305     my ($attrorder) = $order =~ /patron_attr_(.*)$/; 
306     my $patrorder = '';
307     my $sortorder = 'asc';
308     if (defined $attrorder) {
309         ($sortorder, $patrorder) = split /_/, $attrorder, 2;
310     }
311     print STDERR ">>> order is $order, patrorder is $patrorder, sortorder is $sortorder\n" if $debug;
312
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;
316
317         sub patronattr_sorter_asc {
318             lc $a->{patron_attr_value_loop}[$ordinal]{value}
319             cmp
320             lc $b->{patron_attr_value_loop}[$ordinal]{value} }
321
322         sub patronattr_sorter_des { -patronattr_sorter_asc() }
323
324         my $sorter = $sortorder eq 'desc' ? \&patronattr_sorter_des : \&patronattr_sorter_asc;
325         @overduedata = sort $sorter @overduedata;
326     }
327
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;
337     }
338
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();
343
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',
355     );
356
357 }
358
359 output_html_with_http_headers $input, $cookie, $template->output;
360
361
362 sub build_csv {
363     my $overdues = shift;
364
365     return "" if scalar(@$overdues) == 0;
366
367     my @lines = ();
368
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();
374
375     # ... and rest of report
376     foreach my $overdue ( @{ $overdues } ) {
377         push @lines, $csv->string() if $csv->combine(map { $overdue->{$_} } @keys);
378     }
379
380     return join("\n", @lines) . "\n";
381 }