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