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 Text::CSV_XS;
  32 use Koha::DateUtils;
  33 use DateTime;
  34
  35 my $input = new CGI;
  36 my $order           = $input->param('order') || '';
  37 my $showall         = $input->param('showall');
  38 my $bornamefilter   = $input->param('borname') || '';
  39 my $borcatfilter    = $input->param('borcat') || '';
  40 my $itemtypefilter  = $input->param('itemtype') || '';
  41 my $borflagsfilter  = $input->param('borflag') || '';
  42 my $branchfilter    = $input->param('branch') || '';
  43 my $op              = $input->param('op') || '';
  44 my $dateduefrom = format_date_in_iso($input->param( 'dateduefrom' )) || '';
  45 my $datedueto   = format_date_in_iso($input->param( 'datedueto' )) || '';
  46 # FIXME This is a kludge to include times
  47 if ($datedueto) {
  48     $datedueto .= ' 23:59';
  49 }
  50 if ($dateduefrom) {
  51     $dateduefrom .= ' 00:00';
  52 }
  53 # kludge end
  54 my $isfiltered      = $op =~ /apply/i && $op =~ /filter/i;
  55 my $noreport        = C4::Context->preference('FilterBeforeOverdueReport') && ! $isfiltered && $op ne "csv";
  56
  57 my ( $template, $loggedinuser, $cookie ) = get_template_and_user(
  58     {
  59         template_name   => "circ/overdue.tmpl",
  60         query           => $input,
  61         type            => "intranet",
  62         authnotrequired => 0,
  63         flagsrequired   => { reports => 1, circulate => "circulate_remaining_permissions" },
  64         debug           => 1,
  65     }
  66 );
  67
  68 my $dbh = C4::Context->dbh;
  69
  70 my $req;
  71 $req = $dbh->prepare( "select categorycode, description from categories order by description");
  72 $req->execute;
  73 my @borcatloop;
  74 while (my ($catcode, $description) =$req->fetchrow) {
  75     push @borcatloop, {
  76         value    => $catcode,
  77         selected => $catcode eq $borcatfilter ? 1 : 0,
  78         catname  => $description,
  79     };
  80 }
  81
  82 $req = $dbh->prepare( "select itemtype, description from itemtypes order by description");
  83 $req->execute;
  84 my @itemtypeloop;
  85 while (my ($itemtype, $description) =$req->fetchrow) {
  86     push @itemtypeloop, {
  87         value        => $itemtype,
  88         selected     => $itemtype eq $itemtypefilter ? 1 : 0,
  89         itemtypename => $description,
  90     };
  91 }
  92 my $onlymine=C4::Context->preference('IndependantBranches') &&
  93              C4::Context->userenv &&
  94              C4::Context->userenv->{flags} % 2 !=1 &&
  95              C4::Context->userenv->{branch};
  96
  97 $branchfilter = C4::Context->userenv->{'branch'} if ($onlymine && !$branchfilter);
  98
  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
 103
 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;
 110     }
 111 }
 112 my $have_pattr_filter_data = keys(%cgi_attrcode_to_attrvalues) > 0;
 113
 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 }
 116
 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,
 127     };
 128 }
 129
 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,
 156         };
 157     }
 158 } continue { ++$ordinal }
 159 for (@patron_attr_order_loop) { $_->{selected} = 1 if $order eq $_->{value} }
 160
 161 $template->param(ORDER_LOOP => \@order_loop);
 162
 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.
 170
 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},
 182         ];
 183     }
 184
 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;
 196                 }
 197             }
 198             if ($discard) {
 199                 $keep = 0;
 200                 last;
 201             }
 202         }
 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";
 208         }
 209         delete $borrowernumber_to_attributes{$bn} if !$keep;
 210     }
 211 }
 212
 213
 214 $template->param(
 215     patron_attr_header_loop => [ map { { header => $_->{description} } } grep { ! $_->{isclone} } @patron_attr_filter_loop ],
 216     branchloop   => GetBranchesLoop($branchfilter, $onlymine),
 217     branchfilter => $branchfilter,
 218     borcatloop=> \@borcatloop,
 219     itemtypeloop => \@itemtypeloop,
 220     patron_attr_filter_loop => \@patron_attr_filter_loop,
 221     borname => $bornamefilter,
 222     order => $order,
 223     showall => $showall,
 224     DHTMLcalendar_dateformat => C4::Dates->DHTMLcalendar(),
 225     dateduefrom => $input->param( 'dateduefrom' ) || '',
 226     datedueto   => $input->param( 'datedueto' ) || '',
 227 );
 228
 229 if ($noreport) {
 230     # la de dah ... page comes up presto-quicko
 231     $template->param( noreport  => $noreport );
 232 } else {
 233     # FIXME : the left joins + where clauses make the following SQL query really slow with large datasets :(
 234     #
 235     #  FIX 1: use the table with the least rows as first in the join, second least second, etc
 236     #         ref: http://www.fiftyfoureleven.com/weblog/web-development/programming-and-scripts/mysql-optimization-tip
 237     #
 238     #  FIX 2: ensure there are indexes for columns participating in the WHERE clauses, where feasible/reasonable
 239
 240
 241     my $today_dt = DateTime->now(time_zone => C4::Context->tz);
 242     $today_dt->truncate(to => 'minute');
 243     my $todaysdate = $today_dt->strftime('%Y-%m-%d %H:%M');
 244
 245     $bornamefilter =~s/\*/\%/g;
 246     $bornamefilter =~s/\?/\_/g;
 247
 248     my $strsth="SELECT date_due,
 249         borrowers.title as borrowertitle,
 250         borrowers.surname,
 251         borrowers.firstname,
 252         borrowers.streetnumber,
 253         borrowers.streettype,
 254         borrowers.address,
 255         borrowers.address2,
 256         borrowers.city,
 257         borrowers.zipcode,
 258         borrowers.country,
 259         borrowers.phone,
 260         borrowers.email,
 261         issues.itemnumber,
 262         issues.issuedate,
 263         items.barcode,
 264         biblio.title,
 265         biblio.author,
 266         borrowers.borrowernumber,
 267         biblio.biblionumber,
 268         borrowers.branchcode,
 269         items.itemcallnumber,
 270         items.replacementprice,
 271         items.enumchron
 272       FROM issues
 273     LEFT JOIN borrowers   ON (issues.borrowernumber=borrowers.borrowernumber )
 274     LEFT JOIN items       ON (issues.itemnumber=items.itemnumber)
 275     LEFT JOIN biblioitems ON (biblioitems.biblioitemnumber=items.biblioitemnumber)
 276     LEFT JOIN biblio      ON (biblio.biblionumber=items.biblionumber )
 277     WHERE 1=1 "; # placeholder, since it is possible that none of the additional
 278                  # conditions will be selected by user
 279     $strsth.=" AND date_due               < '" . $todaysdate     . "' " unless ($showall);
 280     $strsth.=" AND (borrowers.firstname like '".$bornamefilter."%' or borrowers.surname like '".$bornamefilter."%' or borrowers.cardnumber like '".$bornamefilter."%')" if($bornamefilter) ;
 281     $strsth.=" AND borrowers.categorycode = '" . $borcatfilter   . "' " if $borcatfilter;
 282     if( $itemtypefilter ){
 283         if( C4::Context->preference('item-level_itypes') ){
 284             $strsth.=" AND items.itype   = '" . $itemtypefilter . "' ";
 285         } else {
 286             $strsth.=" AND biblioitems.itemtype   = '" . $itemtypefilter . "' ";
 287         }
 288     }
 289     if ( $borflagsfilter eq 'gonenoaddress' ) {
 290         $strsth .= " AND borrowers.gonenoaddress <> 0";
 291     }
 292     elsif ( $borflagsfilter eq 'debarred' ) {
 293         $strsth .= " AND borrowers.debarred >=  CURDATE()" ;
 294     }
 295     elsif ( $borflagsfilter eq 'lost') {
 296         $strsth .= " AND borrowers.lost <> 0";
 297     }
 298     $strsth.=" AND borrowers.branchcode   = '" . $branchfilter   . "' " if $branchfilter;
 299     $strsth.=" AND date_due < '" . $datedueto . "' "  if $datedueto;
 300     $strsth.=" AND date_due > '" . $dateduefrom . "' " if $dateduefrom;
 301     # restrict patrons (borrowers) to those matching the patron attribute filter(s), if any
 302     my $bnlist = $have_pattr_filter_data ? join(',',keys %borrowernumber_to_attributes) : '';
 303     $strsth =~ s/WHERE 1=1/WHERE 1=1 AND borrowers.borrowernumber IN ($bnlist)/ if $bnlist;
 304     $strsth =~ s/WHERE 1=1/WHERE 0=1/ if $have_pattr_filter_data  && !$bnlist;  # no match if no borrowers matched patron attrs
 305     $strsth.=" ORDER BY " . (
 306         ($order eq "borrower")                              ? "surname, firstname, date_due"               :
 307         ($order eq "borrower desc")                         ? "surname desc, firstname desc, date_due"     :
 308         ($order eq "title"    or $order eq    "title desc") ? "$order, date_due, surname, firstname"       :
 309         ($order eq "barcode"  or $order eq  "barcode desc") ? "items.$order, date_due, surname, firstname" :
 310                                 ($order eq "date_due desc") ? "date_due DESC, surname, firstname"          :
 311                                                             "date_due, surname, firstname"  # default sort order
 312     );
 313     $template->param(sql=>$strsth);
 314     my $sth=$dbh->prepare($strsth);
 315     #warn "overdue.pl : query string ".$strsth;
 316     $sth->execute();
 317
 318     my @overduedata;
 319     while (my $data = $sth->fetchrow_hashref) {
 320
 321         # most of the overdue report data is linked to the database schema, i.e. things like borrowernumber and phone
 322         # but the patron attributes (patron_attr_value_loop) are unnormalised and varies dynamically from one db to the next
 323
 324         my $pattrs = $borrowernumber_to_attributes{$data->{borrowernumber}} || {};  # patron attrs for this borrower
 325         # $pattrs is a hash { attrcode => [  [value,displayvalue], [value,displayvalue]... ] }
 326
 327         my @patron_attr_value_loop;   # template array [ {value=>v1}, {value=>v2} ... } ]
 328         for my $pattr_filter (grep { ! $_->{isclone} } @patron_attr_filter_loop) {
 329             my @displayvalues = map { $_->[1] } @{ $pattrs->{$pattr_filter->{code}} };   # grab second value from each subarray
 330             push @patron_attr_value_loop, { value => join(', ', sort { lc $a cmp lc $b } @displayvalues) };
 331         }
 332         my $dt = dt_from_string($data->{date_due}, 'sql');
 333
 334         push @overduedata, {
 335             duedate                => output_pref($dt),
 336             borrowernumber         => $data->{borrowernumber},
 337             barcode                => $data->{barcode},
 338             itemnum                => $data->{itemnumber},
 339             issuedate              => format_date($data->{issuedate}),
 340             borrowertitle          => $data->{borrowertitle},
 341             surname                => $data->{surname},
 342             firstname              => $data->{firstname},
 343             streetnumber           => $data->{streetnumber},
 344             streettype             => $data->{streettype},
 345             address                => $data->{address},
 346             address2               => $data->{address2},
 347             city                   => $data->{city},
 348             zipcode                => $data->{zipcode},
 349             country                => $data->{country},
 350             phone                  => $data->{phone},
 351             email                  => $data->{email},
 352             biblionumber           => $data->{biblionumber},
 353             title                  => $data->{title},
 354             author                 => $data->{author},
 355             branchcode             => $data->{branchcode},
 356             itemcallnumber         => $data->{itemcallnumber},
 357             replacementprice       => $data->{replacementprice},
 358             enumchron              => $data->{enumchron},
 359             patron_attr_value_loop => \@patron_attr_value_loop,
 360         };
 361     }
 362
 363     my ($attrorder) = $order =~ /patron_attr_(.*)$/;
 364     my $patrorder = '';
 365     my $sortorder = 'asc';
 366     if (defined $attrorder) {
 367         ($sortorder, $patrorder) = split /_/, $attrorder, 2;
 368     }
 369     print STDERR ">>> order is $order, patrorder is $patrorder, sortorder is $sortorder\n" if $debug;
 370
 371     if (my @attrtype = grep { $_->{'code'} eq $patrorder } @patron_attr_filter_loop) {        # sort by patron attrs perhaps?
 372         my $ordinal = $attrtype[0]{ordinal};
 373         print STDERR ">>> sort ordinal is $ordinal\n" if $debug;
 374
 375         sub patronattr_sorter_asc {
 376             lc $a->{patron_attr_value_loop}[$ordinal]{value}
 377             cmp
 378             lc $b->{patron_attr_value_loop}[$ordinal]{value} }
 379
 380         sub patronattr_sorter_des { -patronattr_sorter_asc() }
 381
 382         my $sorter = $sortorder eq 'desc' ? \&patronattr_sorter_des : \&patronattr_sorter_asc;
 383         @overduedata = sort $sorter @overduedata;
 384     }
 385
 386     if ($op eq 'csv') {
 387         binmode(STDOUT, ":encoding(UTF-8)");
 388         my $csv = build_csv(\@overduedata);
 389         print $input->header(-type => 'application/vnd.sun.xml.calc',
 390                              -encoding    => 'utf-8',
 391                              -attachment=>"overdues.csv",
 392                              -filename=>"overdues.csv" );
 393         print $csv;
 394         exit;
 395     }
 396
 397     # generate parameter list for CSV download link
 398     my $new_cgi = CGI->new($input);
 399     $new_cgi->delete('op');
 400     my $csv_param_string = $new_cgi->query_string();
 401
 402     $template->param(
 403         csv_param_string        => $csv_param_string,
 404         todaysdate              => output_pref($today_dt),
 405         overdueloop             => \@overduedata,
 406         nnoverdue               => scalar(@overduedata),
 407         noverdue_is_plural      => scalar(@overduedata) != 1,
 408         noreport                => $noreport,
 409         isfiltered              => $isfiltered,
 410         borflag_gonenoaddress   => $borflagsfilter eq 'gonenoaddress',
 411         borflag_debarred        => $borflagsfilter eq 'debarred',
 412         borflag_lost            => $borflagsfilter eq 'lost',
 413     );
 414
 415 }
 416
 417 output_html_with_http_headers $input, $cookie, $template->output;
 418
 419
 420 sub build_csv {
 421     my $overdues = shift;
 422
 423     return "" if scalar(@$overdues) == 0;
 424
 425     my @lines = ();
 426
 427     # build header ...
 428     my @keys = qw /duedate title author borrowertitle firstname surname phone barcode email address address2 zipcode city country
 429                 branchcode itemcallnumber biblionumber borrowernumber itemnum issuedate replacementprice streetnumber streettype/;
 430     my $csv = Text::CSV_XS->new();
 431     $csv->combine(@keys);
 432     push @lines, $csv->string();
 433
 434     # ... and rest of report
 435     foreach my $overdue ( @{ $overdues } ) {
 436         push @lines, $csv->string() if $csv->combine(map { $overdue->{$_} } @keys);
 437     }
 438
 439     return join("\n", @lines) . "\n";
 440 }