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 use DateTime::Format::MySQL;
  33
  34 my $input = new CGI;
  35 my $order           = $input->param('order') || '';
  36 my $showall         = $input->param('showall');
  37 my $bornamefilter   = $input->param('borname') || '';
  38 my $borcatfilter    = $input->param('borcat') || '';
  39 my $itemtypefilter  = $input->param('itemtype') || '';
  40 my $borflagsfilter  = $input->param('borflag') || '';
  41 my $branchfilter    = $input->param('branch') || '';
  42 my $homebranchfilter    = $input->param('homebranch') || '';
  43 my $holdingbranchfilter = $input->param('holdingbranch') || '';
  44 my $op              = $input->param('op') || '';
  45
  46 my ($dateduefrom, $datedueto);
  47 if ( $dateduefrom = $input->param('dateduefrom') ) {
  48     $dateduefrom = dt_from_string( $dateduefrom );
  49 }
  50 if ( $datedueto = $input->param('datedueto') ) {
  51     $datedueto = dt_from_string( $datedueto )->set_hour(23)->set_minute(59);
  52 }
  53
  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.tt",
  60         query           => $input,
  61         type            => "intranet",
  62         authnotrequired => 0,
  63         flagsrequired   => { circulate => "overdues_report" },
  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 =
  93      C4::Context->preference('IndependentBranches')
  94   && C4::Context->userenv
  95   && !C4::Context->IsSuperLibrarian()
  96   && C4::Context->userenv->{branch};
  97
  98 $branchfilter = C4::Context->userenv->{'branch'} if ($onlymine && !$branchfilter);
  99
 100 # Filtering by Patron Attributes
 101 #  @patron_attr_filter_loop        is non empty if there are any patron attribute filters
 102 #  %cgi_attrcode_to_attrvalues     contains the patron attribute filter values, as returned by the CGI
 103 #  %borrowernumber_to_attributes   is populated by those borrowernumbers matching the patron attribute filters
 104
 105 my %cgi_attrcode_to_attrvalues;     # ( patron_attribute_code => [ zero or more attribute filter values from the CGI ] )
 106 for my $attrcode (grep { /^patron_attr_filter_/ } $input->multi_param) {
 107     if (my @attrvalues = grep { length($_) > 0 } $input->multi_param($attrcode)) {
 108         $attrcode =~ s/^patron_attr_filter_//;
 109         $cgi_attrcode_to_attrvalues{$attrcode} = \@attrvalues;
 110         print STDERR ">>>param($attrcode)[@{[scalar @attrvalues]}] = '@attrvalues'\n" if $debug;
 111     }
 112 }
 113 my $have_pattr_filter_data = keys(%cgi_attrcode_to_attrvalues) > 0;
 114
 115 my @patron_attr_filter_loop;   # array of [ domid cgivalue ismany isclone ordinal code description repeatable authorised_value_category ]
 116 my @patron_attr_order_loop;    # array of { label => $patron_attr_label, value => $patron_attr_order }
 117
 118 my @sort_roots = qw(borrower title barcode date_due);
 119 push @sort_roots, map {$_ . " desc"} @sort_roots;
 120 my @order_loop = ({selected => $order ? 0 : 1});   # initial blank row
 121 foreach (@sort_roots) {
 122     my $tmpl_name = $_;
 123     $tmpl_name =~ s/\s/_/g;
 124     push @order_loop, {
 125         selected => $order eq $_ ? 1 : 0,
 126         ordervalue => $_,
 127         'order_' . $tmpl_name => 1,
 128     };
 129 }
 130
 131 my $sth = $dbh->prepare('SELECT code,description,repeatable,authorised_value_category
 132     FROM borrower_attribute_types
 133     WHERE staff_searchable <> 0
 134     ORDER BY description');
 135 $sth->execute();
 136 my $ordinal = 0;
 137 while (my $row = $sth->fetchrow_hashref) {
 138     $row->{ordinal} = $ordinal;
 139     my $code = $row->{code};
 140     my $cgivalues = $cgi_attrcode_to_attrvalues{$code} || [ '' ];
 141     my $isclone = 0;
 142     $row->{ismany} = @$cgivalues > 1;
 143     my $serial = 0;
 144     for (@$cgivalues) {
 145         $row->{domid} = $ordinal * 1000 + $serial;
 146         $row->{cgivalue} = $_;
 147         $row->{isclone} = $isclone;
 148         push @patron_attr_filter_loop, { %$row };  # careful: must store a *deep copy* of the modified row
 149     } continue { $isclone = 1, ++$serial }
 150     foreach my $sortorder ('asc', 'desc') {
 151         my $ordervalue = "patron_attr_${sortorder}_${code}";
 152         push @order_loop, {
 153             selected => $order eq $ordervalue ? 1 : 0,
 154             ordervalue => $ordervalue,
 155             label => $row->{description},
 156             $sortorder => 1,
 157         };
 158     }
 159 } continue { ++$ordinal }
 160 for (@patron_attr_order_loop) { $_->{selected} = 1 if $order eq $_->{value} }
 161
 162 $template->param(ORDER_LOOP => \@order_loop);
 163
 164 my %borrowernumber_to_attributes;    # hash of { borrowernumber => { attrcode => [ [val,display], [val,display], ... ] } }
 165                                      #   i.e. val differs from display when attr is an authorised value
 166 if (@patron_attr_filter_loop) {
 167     # MAYBE FIXME: currently, *all* borrower_attributes are loaded into %borrowernumber_to_attributes
 168     #              then filtered and honed down to match the patron attribute filters. If this is
 169     #              too resource intensive, MySQL can be used to do the filtering, i.e. rewire the
 170     #              SQL below to select only those attribute values that match the filters.
 171
 172     my $sql = q(SELECT borrowernumber AS bn, b.code, attribute AS val, category AS avcategory, lib AS avdescription
 173         FROM borrower_attributes b
 174         JOIN borrower_attribute_types bt ON (b.code = bt.code)
 175         LEFT JOIN authorised_values a ON (a.category = bt.authorised_value_category AND a.authorised_value = b.attribute));
 176     my $sth = $dbh->prepare($sql);
 177     $sth->execute();
 178     while (my $row = $sth->fetchrow_hashref) {
 179         my $pattrs = $borrowernumber_to_attributes{$row->{bn}} ||= { };
 180         push @{ $pattrs->{$row->{code}} }, [
 181             $row->{val},
 182             defined $row->{avdescription} ? $row->{avdescription} : $row->{val},
 183         ];
 184     }
 185
 186     for my $bn (keys %borrowernumber_to_attributes) {
 187         my $pattrs = $borrowernumber_to_attributes{$bn};
 188         my $keep = 1;
 189         for my $code (keys %cgi_attrcode_to_attrvalues) {
 190             # discard patrons that do not match (case insensitive) at least one of each attribute filter value
 191             my $discard = 1;
 192             for my $attrval (map { lc $_ } @{ $cgi_attrcode_to_attrvalues{$code} }) {
 193                 ## if (grep { $attrval eq lc($_->[0]) } @{ $pattrs->{$code} })
 194                 if (grep { $attrval eq lc($_->[1]) } @{ $pattrs->{$code} }) {
 195                     $discard = 0;
 196                     last;
 197                 }
 198             }
 199             if ($discard) {
 200                 $keep = 0;
 201                 last;
 202             }
 203         }
 204         if ($debug) {
 205             my $showkeep = $keep ? 'keep' : 'do NOT keep';
 206             print STDERR ">>> patron $bn: $showkeep attributes: ";
 207             for (sort keys %$pattrs) { my @a=map { "$_->[0]/$_->[1]  " } @{$pattrs->{$_}}; print STDERR "attrcode $_ = [@a] " }
 208             print STDERR "\n";
 209         }
 210         delete $borrowernumber_to_attributes{$bn} if !$keep;
 211     }
 212 }
 213
 214
 215 $template->param(
 216     patron_attr_header_loop => [ map { { header => $_->{description} } } grep { ! $_->{isclone} } @patron_attr_filter_loop ],
 217     branchloop   => GetBranchesLoop($branchfilter, $onlymine),
 218     homebranchloop => GetBranchesLoop( $homebranchfilter, $onlymine ),
 219     holdingbranchloop => GetBranchesLoop( $holdingbranchfilter, $onlymine ),
 220     branchfilter => $branchfilter,
 221     homebranchfilter => $homebranchfilter,
 222     holdingbranchfilter => $homebranchfilter,
 223     borcatloop=> \@borcatloop,
 224     itemtypeloop => \@itemtypeloop,
 225     patron_attr_filter_loop => \@patron_attr_filter_loop,
 226     borname => $bornamefilter,
 227     order => $order,
 228     showall => $showall,
 229     dateduefrom => $dateduefrom,
 230     datedueto   => $datedueto,
 231 );
 232
 233 if ($noreport) {
 234     # la de dah ... page comes up presto-quicko
 235     $template->param( noreport  => $noreport );
 236 } else {
 237     # FIXME : the left joins + where clauses make the following SQL query really slow with large datasets :(
 238     #
 239     #  FIX 1: use the table with the least rows as first in the join, second least second, etc
 240     #         ref: http://www.fiftyfoureleven.com/weblog/web-development/programming-and-scripts/mysql-optimization-tip
 241     #
 242     #  FIX 2: ensure there are indexes for columns participating in the WHERE clauses, where feasible/reasonable
 243
 244
 245     my $today_dt = DateTime->now(time_zone => C4::Context->tz);
 246     $today_dt->truncate(to => 'minute');
 247     my $todaysdate = $today_dt->strftime('%Y-%m-%d %H:%M');
 248
 249     $bornamefilter =~s/\*/\%/g;
 250     $bornamefilter =~s/\?/\_/g;
 251
 252     my $strsth="SELECT date_due,
 253         borrowers.title as borrowertitle,
 254         borrowers.surname,
 255         borrowers.firstname,
 256         borrowers.streetnumber,
 257         borrowers.streettype,
 258         borrowers.address,
 259         borrowers.address2,
 260         borrowers.city,
 261         borrowers.zipcode,
 262         borrowers.country,
 263         borrowers.phone,
 264         borrowers.email,
 265         borrowers.cardnumber,
 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 >= ?" if $dateduefrom;
 309     $strsth.=" AND date_due <= ?" if $datedueto;
 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     $sth->execute(
 325         ($dateduefrom ? DateTime::Format::MySQL->format_datetime($dateduefrom) : ()),
 326         ($datedueto ? DateTime::Format::MySQL->format_datetime($datedueto) : ()),
 327     );
 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              => output_pref({ dt => dt_from_string( $data->{issuedate} ), dateonly => 1 }),
 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 }