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