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