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