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