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