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