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