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