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::Branch;
  28 use C4::Debug;
  29 use Text::CSV_XS;
  30 use Koha::DateUtils;
  31 use DateTime;
  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 my $onlymine =
  92      C4::Context->preference('IndependentBranches')
  93   && C4::Context->userenv
  94   && !C4::Context->IsSuperLibrarian()
  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     homebranchloop => GetBranchesLoop( $homebranchfilter, $onlymine ),
 218     holdingbranchloop => GetBranchesLoop( $holdingbranchfilter, $onlymine ),
 219     branchfilter => $branchfilter,
 220     homebranchfilter => $homebranchfilter,
 221     holdingbranchfilter => $homebranchfilter,
 222     borcatloop=> \@borcatloop,
 223     itemtypeloop => \@itemtypeloop,
 224     patron_attr_filter_loop => \@patron_attr_filter_loop,
 225     borname => $bornamefilter,
 226     order => $order,
 227     showall => $showall,
 228     dateduefrom => $dateduefrom,
 229     datedueto   => $datedueto,
 230 );
 231
 232 if ($noreport) {
 233     # la de dah ... page comes up presto-quicko
 234     $template->param( noreport  => $noreport );
 235 } else {
 236     # FIXME : the left joins + where clauses make the following SQL query really slow with large datasets :(
 237     #
 238     #  FIX 1: use the table with the least rows as first in the join, second least second, etc
 239     #         ref: http://www.fiftyfoureleven.com/weblog/web-development/programming-and-scripts/mysql-optimization-tip
 240     #
 241     #  FIX 2: ensure there are indexes for columns participating in the WHERE clauses, where feasible/reasonable
 242
 243
 244     my $today_dt = DateTime->now(time_zone => C4::Context->tz);
 245     $today_dt->truncate(to => 'minute');
 246     my $todaysdate = $today_dt->strftime('%Y-%m-%d %H:%M');
 247
 248     $bornamefilter =~s/\*/\%/g;
 249     $bornamefilter =~s/\?/\_/g;
 250
 251     my $strsth="SELECT date_due,
 252         borrowers.title as borrowertitle,
 253         borrowers.surname,
 254         borrowers.firstname,
 255         borrowers.streetnumber,
 256         borrowers.streettype,
 257         borrowers.address,
 258         borrowers.address2,
 259         borrowers.city,
 260         borrowers.zipcode,
 261         borrowers.country,
 262         borrowers.phone,
 263         borrowers.email,
 264         borrowers.cardnumber,
 265         issues.itemnumber,
 266         issues.issuedate,
 267         items.barcode,
 268         items.homebranch,
 269         items.holdingbranch,
 270         biblio.title,
 271         biblio.author,
 272         borrowers.borrowernumber,
 273         biblio.biblionumber,
 274         borrowers.branchcode,
 275         items.itemcallnumber,
 276         items.replacementprice,
 277         items.enumchron
 278       FROM issues
 279     LEFT JOIN borrowers   ON (issues.borrowernumber=borrowers.borrowernumber )
 280     LEFT JOIN items       ON (issues.itemnumber=items.itemnumber)
 281     LEFT JOIN biblioitems ON (biblioitems.biblioitemnumber=items.biblioitemnumber)
 282     LEFT JOIN biblio      ON (biblio.biblionumber=items.biblionumber )
 283     WHERE 1=1 "; # placeholder, since it is possible that none of the additional
 284                  # conditions will be selected by user
 285     $strsth.=" AND date_due               < '" . $todaysdate     . "' " unless ($showall);
 286     $strsth.=" AND (borrowers.firstname like '".$bornamefilter."%' or borrowers.surname like '".$bornamefilter."%' or borrowers.cardnumber like '".$bornamefilter."%')" if($bornamefilter) ;
 287     $strsth.=" AND borrowers.categorycode = '" . $borcatfilter   . "' " if $borcatfilter;
 288     if( $itemtypefilter ){
 289         if( C4::Context->preference('item-level_itypes') ){
 290             $strsth.=" AND items.itype   = '" . $itemtypefilter . "' ";
 291         } else {
 292             $strsth.=" AND biblioitems.itemtype   = '" . $itemtypefilter . "' ";
 293         }
 294     }
 295     if ( $borflagsfilter eq 'gonenoaddress' ) {
 296         $strsth .= " AND borrowers.gonenoaddress <> 0";
 297     }
 298     elsif ( $borflagsfilter eq 'debarred' ) {
 299         $strsth .= " AND borrowers.debarred >=  CURDATE()" ;
 300     }
 301     elsif ( $borflagsfilter eq 'lost') {
 302         $strsth .= " AND borrowers.lost <> 0";
 303     }
 304     $strsth.=" AND borrowers.branchcode   = '" . $branchfilter   . "' " if $branchfilter;
 305     $strsth.=" AND items.homebranch       = '" . $homebranchfilter . "' " if $homebranchfilter;
 306     $strsth.=" AND items.holdingbranch    = '" . $holdingbranchfilter . "' " if $holdingbranchfilter;
 307     $strsth.=" AND date_due >= ?" if $dateduefrom;
 308     $strsth.=" AND date_due <= ?" if $datedueto;
 309     # restrict patrons (borrowers) to those matching the patron attribute filter(s), if any
 310     my $bnlist = $have_pattr_filter_data ? join(',',keys %borrowernumber_to_attributes) : '';
 311     $strsth =~ s/WHERE 1=1/WHERE 1=1 AND borrowers.borrowernumber IN ($bnlist)/ if $bnlist;
 312     $strsth =~ s/WHERE 1=1/WHERE 0=1/ if $have_pattr_filter_data  && !$bnlist;  # no match if no borrowers matched patron attrs
 313     $strsth.=" ORDER BY " . (
 314         ($order eq "borrower")                              ? "surname, firstname, date_due"               :
 315         ($order eq "borrower desc")                         ? "surname desc, firstname desc, date_due"     :
 316         ($order eq "title"    or $order eq    "title desc") ? "$order, date_due, surname, firstname"       :
 317         ($order eq "barcode"  or $order eq  "barcode desc") ? "items.$order, date_due, surname, firstname" :
 318                                 ($order eq "date_due desc") ? "date_due DESC, surname, firstname"          :
 319                                                             "date_due, surname, firstname"  # default sort order
 320     );
 321     $template->param(sql=>$strsth);
 322     my $sth=$dbh->prepare($strsth);
 323     $sth->execute(
 324         ($dateduefrom ? output_pref({ dt => $dateduefrom, dateformat => 'iso' }) : ()),
 325         ($datedueto ? output_pref({ dt => $datedueto, dateformat => 'iso' }) : ()),
 326     );
 327
 328     my @overduedata;
 329     while (my $data = $sth->fetchrow_hashref) {
 330
 331         # most of the overdue report data is linked to the database schema, i.e. things like borrowernumber and phone
 332         # but the patron attributes (patron_attr_value_loop) are unnormalised and varies dynamically from one db to the next
 333
 334         my $pattrs = $borrowernumber_to_attributes{$data->{borrowernumber}} || {};  # patron attrs for this borrower
 335         # $pattrs is a hash { attrcode => [  [value,displayvalue], [value,displayvalue]... ] }
 336
 337         my @patron_attr_value_loop;   # template array [ {value=>v1}, {value=>v2} ... } ]
 338         for my $pattr_filter (grep { ! $_->{isclone} } @patron_attr_filter_loop) {
 339             my @displayvalues = map { $_->[1] } @{ $pattrs->{$pattr_filter->{code}} };   # grab second value from each subarray
 340             push @patron_attr_value_loop, { value => join(', ', sort { lc $a cmp lc $b } @displayvalues) };
 341         }
 342         my $dt = dt_from_string($data->{date_due}, 'sql');
 343
 344         push @overduedata, {
 345             duedate                => output_pref($dt),
 346             borrowernumber         => $data->{borrowernumber},
 347             barcode                => $data->{barcode},
 348             cardnumber             => $data->{cardnumber},
 349             itemnum                => $data->{itemnumber},
 350             issuedate              => output_pref({ dt => dt_from_string( $data->{issuedate} ), dateonly => 1 }),
 351             borrowertitle          => $data->{borrowertitle},
 352             surname                => $data->{surname},
 353             firstname              => $data->{firstname},
 354             streetnumber           => $data->{streetnumber},
 355             streettype             => $data->{streettype},
 356             address                => $data->{address},
 357             address2               => $data->{address2},
 358             city                   => $data->{city},
 359             zipcode                => $data->{zipcode},
 360             country                => $data->{country},
 361             phone                  => $data->{phone},
 362             email                  => $data->{email},
 363             biblionumber           => $data->{biblionumber},
 364             title                  => $data->{title},
 365             author                 => $data->{author},
 366             branchcode             => $data->{branchcode},
 367             homebranchcode         => $data->{homebranchcode},
 368             holdingbranchcode      => $data->{holdingbranchcode},
 369             itemcallnumber         => $data->{itemcallnumber},
 370             replacementprice       => $data->{replacementprice},
 371             enumchron              => $data->{enumchron},
 372             patron_attr_value_loop => \@patron_attr_value_loop,
 373         };
 374     }
 375
 376     my ($attrorder) = $order =~ /patron_attr_(.*)$/;
 377     my $patrorder = '';
 378     my $sortorder = 'asc';
 379     if (defined $attrorder) {
 380         ($sortorder, $patrorder) = split /_/, $attrorder, 2;
 381     }
 382     print STDERR ">>> order is $order, patrorder is $patrorder, sortorder is $sortorder\n" if $debug;
 383
 384     if (my @attrtype = grep { $_->{'code'} eq $patrorder } @patron_attr_filter_loop) {        # sort by patron attrs perhaps?
 385         my $ordinal = $attrtype[0]{ordinal};
 386         print STDERR ">>> sort ordinal is $ordinal\n" if $debug;
 387
 388         sub patronattr_sorter_asc {
 389             lc $a->{patron_attr_value_loop}[$ordinal]{value}
 390             cmp
 391             lc $b->{patron_attr_value_loop}[$ordinal]{value} }
 392
 393         sub patronattr_sorter_des { -patronattr_sorter_asc() }
 394
 395         my $sorter = $sortorder eq 'desc' ? \&patronattr_sorter_des : \&patronattr_sorter_asc;
 396         @overduedata = sort $sorter @overduedata;
 397     }
 398
 399     if ($op eq 'csv') {
 400         binmode(STDOUT, ":encoding(UTF-8)");
 401         my $csv = build_csv(\@overduedata);
 402         print $input->header(-type => 'application/vnd.sun.xml.calc',
 403                              -encoding    => 'utf-8',
 404                              -attachment=>"overdues.csv",
 405                              -filename=>"overdues.csv" );
 406         print $csv;
 407         exit;
 408     }
 409
 410     # generate parameter list for CSV download link
 411     my $new_cgi = CGI->new($input);
 412     $new_cgi->delete('op');
 413     my $csv_param_string = $new_cgi->query_string();
 414
 415     $template->param(
 416         csv_param_string        => $csv_param_string,
 417         todaysdate              => output_pref($today_dt),
 418         overdueloop             => \@overduedata,
 419         nnoverdue               => scalar(@overduedata),
 420         noverdue_is_plural      => scalar(@overduedata) != 1,
 421         noreport                => $noreport,
 422         isfiltered              => $isfiltered,
 423         borflag_gonenoaddress   => $borflagsfilter eq 'gonenoaddress',
 424         borflag_debarred        => $borflagsfilter eq 'debarred',
 425         borflag_lost            => $borflagsfilter eq 'lost',
 426     );
 427
 428 }
 429
 430 output_html_with_http_headers $input, $cookie, $template->output;
 431
 432
 433 sub build_csv {
 434     my $overdues = shift;
 435
 436     return "" if scalar(@$overdues) == 0;
 437
 438     my @lines = ();
 439
 440     # build header ...
 441     my @keys = qw /duedate title author borrowertitle firstname surname phone barcode email address address2 zipcode city country
 442                 branchcode itemcallnumber biblionumber borrowernumber itemnum issuedate replacementprice streetnumber streettype/;
 443     my $csv = Text::CSV_XS->new();
 444     $csv->combine(@keys);
 445     push @lines, $csv->string();
 446
 447     # ... and rest of report
 448     foreach my $overdue ( @{ $overdues } ) {
 449         push @lines, $csv->string() if $csv->combine(map { $overdue->{$_} } @keys);
 450     }
 451
 452     return join("\n", @lines) . "\n";
 453 }