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