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