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     branchfilter => $branchfilter,
 218     homebranchfilter => $homebranchfilter,
 219     holdingbranchfilter => $homebranchfilter,
 220     borcatloop=> \@borcatloop,
 221     itemtypeloop => \@itemtypeloop,
 222     patron_attr_filter_loop => \@patron_attr_filter_loop,
 223     borname => $bornamefilter,
 224     order => $order,
 225     showall => $showall,
 226     dateduefrom => $dateduefrom,
 227     datedueto   => $datedueto,
 228 );
 229
 230 if ($noreport) {
 231     # la de dah ... page comes up presto-quicko
 232     $template->param( noreport  => $noreport );
 233 } else {
 234     # FIXME : the left joins + where clauses make the following SQL query really slow with large datasets :(
 235     #
 236     #  FIX 1: use the table with the least rows as first in the join, second least second, etc
 237     #         ref: http://www.fiftyfoureleven.com/weblog/web-development/programming-and-scripts/mysql-optimization-tip
 238     #
 239     #  FIX 2: ensure there are indexes for columns participating in the WHERE clauses, where feasible/reasonable
 240
 241
 242     my $today_dt = DateTime->now(time_zone => C4::Context->tz);
 243     $today_dt->truncate(to => 'minute');
 244     my $todaysdate = $today_dt->strftime('%Y-%m-%d %H:%M');
 245
 246     $bornamefilter =~s/\*/\%/g;
 247     $bornamefilter =~s/\?/\_/g;
 248
 249     my $strsth="SELECT date_due,
 250         borrowers.title as borrowertitle,
 251         borrowers.surname,
 252         borrowers.firstname,
 253         borrowers.streetnumber,
 254         borrowers.streettype,
 255         borrowers.address,
 256         borrowers.address2,
 257         borrowers.city,
 258         borrowers.zipcode,
 259         borrowers.country,
 260         borrowers.phone,
 261         borrowers.email,
 262         borrowers.cardnumber,
 263         issues.itemnumber,
 264         issues.issuedate,
 265         items.barcode,
 266         items.homebranch,
 267         items.holdingbranch,
 268         biblio.title,
 269         biblio.author,
 270         borrowers.borrowernumber,
 271         biblio.biblionumber,
 272         borrowers.branchcode,
 273         items.itemcallnumber,
 274         items.replacementprice,
 275         items.enumchron
 276       FROM issues
 277     LEFT JOIN borrowers   ON (issues.borrowernumber=borrowers.borrowernumber )
 278     LEFT JOIN items       ON (issues.itemnumber=items.itemnumber)
 279     LEFT JOIN biblioitems ON (biblioitems.biblioitemnumber=items.biblioitemnumber)
 280     LEFT JOIN biblio      ON (biblio.biblionumber=items.biblionumber )
 281     WHERE 1=1 "; # placeholder, since it is possible that none of the additional
 282                  # conditions will be selected by user
 283     $strsth.=" AND date_due               < '" . $todaysdate     . "' " unless ($showall);
 284     $strsth.=" AND (borrowers.firstname like '".$bornamefilter."%' or borrowers.surname like '".$bornamefilter."%' or borrowers.cardnumber like '".$bornamefilter."%')" if($bornamefilter) ;
 285     $strsth.=" AND borrowers.categorycode = '" . $borcatfilter   . "' " if $borcatfilter;
 286     if( $itemtypefilter ){
 287         if( C4::Context->preference('item-level_itypes') ){
 288             $strsth.=" AND items.itype   = '" . $itemtypefilter . "' ";
 289         } else {
 290             $strsth.=" AND biblioitems.itemtype   = '" . $itemtypefilter . "' ";
 291         }
 292     }
 293     if ( $borflagsfilter eq 'gonenoaddress' ) {
 294         $strsth .= " AND borrowers.gonenoaddress <> 0";
 295     }
 296     elsif ( $borflagsfilter eq 'debarred' ) {
 297         $strsth .= " AND borrowers.debarred >=  CURDATE()" ;
 298     }
 299     elsif ( $borflagsfilter eq 'lost') {
 300         $strsth .= " AND borrowers.lost <> 0";
 301     }
 302     $strsth.=" AND borrowers.branchcode   = '" . $branchfilter   . "' " if $branchfilter;
 303     $strsth.=" AND items.homebranch       = '" . $homebranchfilter . "' " if $homebranchfilter;
 304     $strsth.=" AND items.holdingbranch    = '" . $holdingbranchfilter . "' " if $holdingbranchfilter;
 305     $strsth.=" AND date_due >= ?" if $dateduefrom;
 306     $strsth.=" AND date_due <= ?" if $datedueto;
 307     # restrict patrons (borrowers) to those matching the patron attribute filter(s), if any
 308     my $bnlist = $have_pattr_filter_data ? join(',',keys %borrowernumber_to_attributes) : '';
 309     $strsth =~ s/WHERE 1=1/WHERE 1=1 AND borrowers.borrowernumber IN ($bnlist)/ if $bnlist;
 310     $strsth =~ s/WHERE 1=1/WHERE 0=1/ if $have_pattr_filter_data  && !$bnlist;  # no match if no borrowers matched patron attrs
 311     $strsth.=" ORDER BY " . (
 312         ($order eq "borrower")                              ? "surname, firstname, date_due"               :
 313         ($order eq "borrower desc")                         ? "surname desc, firstname desc, date_due"     :
 314         ($order eq "title"    or $order eq    "title desc") ? "$order, date_due, surname, firstname"       :
 315         ($order eq "barcode"  or $order eq  "barcode desc") ? "items.$order, date_due, surname, firstname" :
 316                                 ($order eq "date_due desc") ? "date_due DESC, surname, firstname"          :
 317                                                             "date_due, surname, firstname"  # default sort order
 318     );
 319     $template->param(sql=>$strsth);
 320     my $sth=$dbh->prepare($strsth);
 321     $sth->execute(
 322         ($dateduefrom ? DateTime::Format::MySQL->format_datetime($dateduefrom) : ()),
 323         ($datedueto ? DateTime::Format::MySQL->format_datetime($datedueto) : ()),
 324     );
 325
 326     my @overduedata;
 327     while (my $data = $sth->fetchrow_hashref) {
 328
 329         # most of the overdue report data is linked to the database schema, i.e. things like borrowernumber and phone
 330         # but the patron attributes (patron_attr_value_loop) are unnormalised and varies dynamically from one db to the next
 331
 332         my $pattrs = $borrowernumber_to_attributes{$data->{borrowernumber}} || {};  # patron attrs for this borrower
 333         # $pattrs is a hash { attrcode => [  [value,displayvalue], [value,displayvalue]... ] }
 334
 335         my @patron_attr_value_loop;   # template array [ {value=>v1}, {value=>v2} ... } ]
 336         for my $pattr_filter (grep { ! $_->{isclone} } @patron_attr_filter_loop) {
 337             my @displayvalues = map { $_->[1] } @{ $pattrs->{$pattr_filter->{code}} };   # grab second value from each subarray
 338             push @patron_attr_value_loop, { value => join(', ', sort { lc $a cmp lc $b } @displayvalues) };
 339         }
 340         my $dt = dt_from_string($data->{date_due}, 'sql');
 341
 342         push @overduedata, {
 343             duedate                => output_pref($dt),
 344             borrowernumber         => $data->{borrowernumber},
 345             barcode                => $data->{barcode},
 346             cardnumber             => $data->{cardnumber},
 347             itemnum                => $data->{itemnumber},
 348             issuedate              => output_pref({ dt => dt_from_string( $data->{issuedate} ), dateonly => 1 }),
 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 }