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