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