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