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 under the
  10 # terms of the GNU General Public License as published by the Free Software
  11 # Foundation; either version 2 of the License, or (at your option) any later
  12 # version.
  13 #
  14 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  15 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  16 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License along
  19 # with Koha; if not, write to the Free Software Foundation, Inc.,
  20 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  21
  22 use strict;
  23 use warnings;
  24 use C4::Context;
  25 use C4::Output;
  26 use CGI qw(-oldstyle_urls);
  27 use C4::Auth;
  28 use C4::Branch;
  29 use C4::Debug;
  30 use C4::Dates qw/format_date/;
  31 use Date::Calc qw/Today/;
  32 use Text::CSV_XS;
  33
  34 my $input = new CGI;
  35 my $order           = $input->param('order') || '';
  36 my $showall         = $input->param('showall');
  37 my $bornamefilter   = $input->param('borname') || '';
  38 my $borcatfilter    = $input->param('borcat') || '';
  39 my $itemtypefilter  = $input->param('itemtype') || '';
  40 my $borflagsfilter  = $input->param('borflag') || '';
  41 my $branchfilter    = $input->param('branch') || '';
  42 my $op              = $input->param('op') || '';
  43 my $isfiltered      = $op =~ /apply/i && $op =~ /filter/i;
  44 my $noreport        = C4::Context->preference('FilterBeforeOverdueReport') && ! $isfiltered && $op ne "csv";
  45
  46 my ( $template, $loggedinuser, $cookie ) = get_template_and_user(
  47     {
  48         template_name   => "circ/overdue.tmpl",
  49         query           => $input,
  50         type            => "intranet",
  51         authnotrequired => 0,
  52         flagsrequired   => { reports => 1, circulate => "circulate_remaining_permissions" },
  53         debug           => 1,
  54     }
  55 );
  56
  57 my $dbh = C4::Context->dbh;
  58
  59 my $req;
  60 $req = $dbh->prepare( "select categorycode, description from categories order by description");
  61 $req->execute;
  62 my @borcatloop;
  63 while (my ($catcode, $description) =$req->fetchrow) {
  64     push @borcatloop, {
  65         value    => $catcode,
  66         selected => $catcode eq $borcatfilter ? 1 : 0,
  67         catname  => $description,
  68     };
  69 }
  70
  71 $req = $dbh->prepare( "select itemtype, description from itemtypes order by description");
  72 $req->execute;
  73 my @itemtypeloop;
  74 while (my ($itemtype, $description) =$req->fetchrow) {
  75     push @itemtypeloop, {
  76         value        => $itemtype,
  77         selected     => $itemtype eq $itemtypefilter ? 1 : 0,
  78         itemtypename => $description,
  79     };
  80 }
  81 my $onlymine=C4::Context->preference('IndependantBranches') &&
  82              C4::Context->userenv &&
  83              C4::Context->userenv->{flags} % 2 !=1 &&
  84              C4::Context->userenv->{branch};
  85
  86 $branchfilter = C4::Context->userenv->{'branch'} if ($onlymine && !$branchfilter);
  87
  88 # Filtering by Patron Attributes
  89 #  @patron_attr_filter_loop        is non empty if there are any patron attribute filters
  90 #  %cgi_attrcode_to_attrvalues     contains the patron attribute filter values, as returned by the CGI
  91 #  %borrowernumber_to_attributes   is populated by those borrowernumbers matching the patron attribute filters
  92
  93 my %cgi_attrcode_to_attrvalues;     # ( patron_attribute_code => [ zero or more attribute filter values from the CGI ] )
  94 for my $attrcode (grep { /^patron_attr_filter_/ } $input->param) {
  95     if (my @attrvalues = grep { length($_) > 0 } $input->param($attrcode)) {
  96         $attrcode =~ s/^patron_attr_filter_//;
  97         $cgi_attrcode_to_attrvalues{$attrcode} = \@attrvalues;
  98         print STDERR ">>>param($attrcode)[@{[scalar @attrvalues]}] = '@attrvalues'\n" if $debug;
  99     }
 100 }
 101 my $have_pattr_filter_data = keys(%cgi_attrcode_to_attrvalues) > 0;
 102
 103 my @patron_attr_filter_loop;   # array of [ domid cgivalue ismany isclone ordinal code description repeatable authorised_value_category ]
 104 my @patron_attr_order_loop;    # array of { label => $patron_attr_label, value => $patron_attr_order }
 105
 106 my @sort_roots = qw(borrower title barcode date_due);
 107 push @sort_roots, map {$_ . " desc"} @sort_roots;
 108 my @order_loop = ({selected => $order ? 0 : 1});   # initial blank row
 109 foreach (@sort_roots) {
 110     my $tmpl_name = $_;
 111     $tmpl_name =~ s/\s/_/g;
 112     push @order_loop, {
 113         selected => $order eq $_ ? 1 : 0,
 114         ordervalue => $_,
 115         'order_' . $tmpl_name => 1,
 116     };
 117 }
 118
 119 my $sth = $dbh->prepare('SELECT code,description,repeatable,authorised_value_category
 120     FROM borrower_attribute_types
 121     WHERE staff_searchable <> 0
 122     ORDER BY description');
 123 $sth->execute();
 124 my $ordinal = 0;
 125 while (my $row = $sth->fetchrow_hashref) {
 126     $row->{ordinal} = $ordinal;
 127     my $code = $row->{code};
 128     my $cgivalues = $cgi_attrcode_to_attrvalues{$code} || [ '' ];
 129     my $isclone = 0;
 130     $row->{ismany} = @$cgivalues > 1;
 131     my $serial = 0;
 132     for (@$cgivalues) {
 133         $row->{domid} = $ordinal * 1000 + $serial;
 134         $row->{cgivalue} = $_;
 135         $row->{isclone} = $isclone;
 136         push @patron_attr_filter_loop, { %$row };  # careful: must store a *deep copy* of the modified row
 137     } continue { $isclone = 1, ++$serial }
 138     foreach my $sortorder ('asc', 'desc') {
 139         my $ordervalue = "patron_attr_${sortorder}_${code}";
 140         push @order_loop, {
 141             selected => $order eq $ordervalue ? 1 : 0,
 142             ordervalue => $ordervalue,
 143             label => $row->{description},
 144             $sortorder => 1,
 145         };
 146     }
 147 } continue { ++$ordinal }
 148 for (@patron_attr_order_loop) { $_->{selected} = 1 if $order eq $_->{value} }
 149
 150 $template->param(ORDER_LOOP => \@order_loop);
 151
 152 my %borrowernumber_to_attributes;    # hash of { borrowernumber => { attrcode => [ [val,display], [val,display], ... ] } }
 153                                      #   i.e. val differs from display when attr is an authorised value
 154 if (@patron_attr_filter_loop) {
 155     # MAYBE FIXME: currently, *all* borrower_attributes are loaded into %borrowernumber_to_attributes
 156     #              then filtered and honed down to match the patron attribute filters. If this is
 157     #              too resource intensive, MySQL can be used to do the filtering, i.e. rewire the
 158     #              SQL below to select only those attribute values that match the filters.
 159
 160     my $sql = q(SELECT borrowernumber AS bn, b.code, attribute AS val, category AS avcategory, lib AS avdescription
 161         FROM borrower_attributes b
 162         JOIN borrower_attribute_types bt ON (b.code = bt.code)
 163         LEFT JOIN authorised_values a ON (a.category = bt.authorised_value_category AND a.authorised_value = b.attribute));
 164     my $sth = $dbh->prepare($sql);
 165     $sth->execute();
 166     while (my $row = $sth->fetchrow_hashref) {
 167         my $pattrs = $borrowernumber_to_attributes{$row->{bn}} ||= { };
 168         push @{ $pattrs->{$row->{code}} }, [
 169             $row->{val},
 170             defined $row->{avdescription} ? $row->{avdescription} : $row->{val},
 171         ];
 172     }
 173
 174     for my $bn (keys %borrowernumber_to_attributes) {
 175         my $pattrs = $borrowernumber_to_attributes{$bn};
 176         my $keep = 1;
 177         for my $code (keys %cgi_attrcode_to_attrvalues) {
 178             # discard patrons that do not match (case insensitive) at least one of each attribute filter value
 179             my $discard = 1;
 180             for my $attrval (map { lc $_ } @{ $cgi_attrcode_to_attrvalues{$code} }) {
 181                 ## if (grep { $attrval eq lc($_->[0]) } @{ $pattrs->{$code} })
 182                 if (grep { $attrval eq lc($_->[1]) } @{ $pattrs->{$code} }) {
 183                     $discard = 0;
 184                     last;
 185                 }
 186             }
 187             if ($discard) {
 188                 $keep = 0;
 189                 last;
 190             }
 191         }
 192         if ($debug) {
 193             my $showkeep = $keep ? 'keep' : 'do NOT keep';
 194             print STDERR ">>> patron $bn: $showkeep attributes: ";
 195             for (sort keys %$pattrs) { my @a=map { "$_->[0]/$_->[1]  " } @{$pattrs->{$_}}; print STDERR "attrcode $_ = [@a] " }
 196             print STDERR "\n";
 197         }
 198         delete $borrowernumber_to_attributes{$bn} if !$keep;
 199     }
 200 }
 201
 202
 203 $template->param(
 204     patron_attr_header_loop => [ map { { header => $_->{description} } } grep { ! $_->{isclone} } @patron_attr_filter_loop ],
 205     branchloop   => GetBranchesLoop($branchfilter, $onlymine),
 206     branchfilter => $branchfilter,
 207     borcatloop=> \@borcatloop,
 208     itemtypeloop => \@itemtypeloop,
 209     patron_attr_filter_loop => \@patron_attr_filter_loop,
 210     borname => $bornamefilter,
 211     order => $order,
 212     showall => $showall);
 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 $todaysdate = sprintf("%-04.4d-%-02.2d-%02.2d", Today());
 227
 228     $bornamefilter =~s/\*/\%/g;
 229     $bornamefilter =~s/\?/\_/g;
 230
 231     my $strsth="SELECT date_due,
 232         borrowers.title as borrowertitle,
 233         concat(surname,' ', firstname) as borrower,
 234         borrowers.streetnumber,
 235         borrowers.streettype,
 236         borrowers.address,
 237         borrowers.address2,
 238         borrowers.city,
 239         borrowers.zipcode,
 240         borrowers.country,
 241         borrowers.phone,
 242         borrowers.email,
 243         issues.itemnumber,
 244         items.barcode,
 245         biblio.title,
 246         biblio.author,
 247         borrowers.borrowernumber,
 248         biblio.biblionumber,
 249         borrowers.branchcode,
 250         items.itemcallnumber,
 251         items.replacementprice
 252       FROM issues
 253     LEFT JOIN borrowers   ON (issues.borrowernumber=borrowers.borrowernumber )
 254     LEFT JOIN items       ON (issues.itemnumber=items.itemnumber)
 255     LEFT JOIN biblioitems ON (biblioitems.biblioitemnumber=items.biblioitemnumber)
 256     LEFT JOIN biblio      ON (biblio.biblionumber=items.biblionumber )
 257     WHERE 1=1 "; # placeholder, since it is possible that none of the additional
 258                  # conditions will be selected by user
 259     $strsth.=" AND date_due               < '" . $todaysdate     . "' " unless ($showall);
 260     $strsth.=" AND (borrowers.firstname like '".$bornamefilter."%' or borrowers.surname like '".$bornamefilter."%' or borrowers.cardnumber like '".$bornamefilter."%')" if($bornamefilter) ;
 261     $strsth.=" AND borrowers.categorycode = '" . $borcatfilter   . "' " if $borcatfilter;
 262     $strsth.=" AND biblioitems.itemtype   = '" . $itemtypefilter . "' " if $itemtypefilter;
 263     $strsth.=" AND borrowers.flags        = '" . $borflagsfilter . "' " if $borflagsfilter;
 264     $strsth.=" AND borrowers.branchcode   = '" . $branchfilter   . "' " if $branchfilter;
 265     # restrict patrons (borrowers) to those matching the patron attribute filter(s), if any
 266     my $bnlist = $have_pattr_filter_data ? join(',',keys %borrowernumber_to_attributes) : '';
 267     $strsth =~ s/WHERE 1=1/WHERE 1=1 AND borrowers.borrowernumber IN ($bnlist)/ if $bnlist;
 268     $strsth =~ s/WHERE 1=1/WHERE 0=1/ if $have_pattr_filter_data  && !$bnlist;  # no match if no borrowers matched patron attrs
 269     $strsth.=" ORDER BY " . (
 270         ($order eq "borrower" or $order eq "borrower desc") ? "$order, date_due"                 :
 271         ($order eq "title"    or $order eq    "title desc") ? "$order, date_due, borrower"       :
 272         ($order eq "barcode"  or $order eq  "barcode desc") ? "items.$order, date_due, borrower" :
 273                                 ($order eq "date_due desc") ? "date_due DESC, borrower"          :
 274                                                             "date_due, borrower"  # default sort order
 275     );
 276     $template->param(sql=>$strsth);
 277     my $sth=$dbh->prepare($strsth);
 278     #warn "overdue.pl : query string ".$strsth;
 279     $sth->execute();
 280
 281     my @overduedata;
 282     while (my $data = $sth->fetchrow_hashref) {
 283
 284         # most of the overdue report data is linked to the database schema, i.e. things like borrowernumber and phone
 285         # but the patron attributes (patron_attr_value_loop) are unnormalised and varies dynamically from one db to the next
 286
 287         my $pattrs = $borrowernumber_to_attributes{$data->{borrowernumber}} || {};  # patron attrs for this borrower
 288         # $pattrs is a hash { attrcode => [  [value,displayvalue], [value,displayvalue]... ] }
 289
 290         my @patron_attr_value_loop;   # template array [ {value=>v1}, {value=>v2} ... } ]
 291         for my $pattr_filter (grep { ! $_->{isclone} } @patron_attr_filter_loop) {
 292             my @displayvalues = map { $_->[1] } @{ $pattrs->{$pattr_filter->{code}} };   # grab second value from each subarray
 293             push @patron_attr_value_loop, { value => join(', ', sort { lc $a cmp lc $b } @displayvalues) };
 294         }
 295
 296         push @overduedata, {
 297             duedate                => format_date($data->{date_due}),
 298             borrowernumber         => $data->{borrowernumber},
 299             barcode                => $data->{barcode},
 300             itemnum                => $data->{itemnumber},
 301             borrowertitle          => $data->{borrowertitle},
 302             name                   => $data->{borrower},
 303             streetnumber           => $data->{streetnumber},
 304             streettype             => $data->{streettype},
 305             address                => $data->{address},
 306             address2               => $data->{address2},
 307             city                   => $data->{city},
 308             zipcode                => $data->{zipcode},
 309             country                => $data->{country},
 310             phone                  => $data->{phone},
 311             email                  => $data->{email},
 312             biblionumber           => $data->{biblionumber},
 313             title                  => $data->{title},
 314             author                 => $data->{author},
 315             branchcode             => $data->{branchcode},
 316             itemcallnumber         => $data->{itemcallnumber},
 317             replacementprice       => $data->{replacementprice},
 318             patron_attr_value_loop => \@patron_attr_value_loop,
 319         };
 320     }
 321
 322     my ($attrorder) = $order =~ /patron_attr_(.*)$/;
 323     my $patrorder = '';
 324     my $sortorder = 'asc';
 325     if (defined $attrorder) {
 326         ($sortorder, $patrorder) = split /_/, $attrorder, 2;
 327     }
 328     print STDERR ">>> order is $order, patrorder is $patrorder, sortorder is $sortorder\n" if $debug;
 329
 330     if (my @attrtype = grep { $_->{'code'} eq $patrorder } @patron_attr_filter_loop) {        # sort by patron attrs perhaps?
 331         my $ordinal = $attrtype[0]{ordinal};
 332         print STDERR ">>> sort ordinal is $ordinal\n" if $debug;
 333
 334         sub patronattr_sorter_asc {
 335             lc $a->{patron_attr_value_loop}[$ordinal]{value}
 336             cmp
 337             lc $b->{patron_attr_value_loop}[$ordinal]{value} }
 338
 339         sub patronattr_sorter_des { -patronattr_sorter_asc() }
 340
 341         my $sorter = $sortorder eq 'desc' ? \&patronattr_sorter_des : \&patronattr_sorter_asc;
 342         @overduedata = sort $sorter @overduedata;
 343     }
 344
 345     if ($op eq 'csv') {
 346         binmode(STDOUT, ":utf8");
 347         my $csv = build_csv(\@overduedata);
 348         print $input->header(-type => 'application/vnd.sun.xml.calc',
 349                              -encoding    => 'utf-8',
 350                              -attachment=>"overdues.csv",
 351                              -filename=>"overdues.csv" );
 352         print $csv;
 353         exit;
 354     }
 355
 356     # generate parameter list for CSV download link
 357     my $new_cgi = CGI->new($input);
 358     $new_cgi->delete('op');
 359     my $csv_param_string = $new_cgi->query_string();
 360
 361     $template->param(
 362         csv_param_string        => $csv_param_string,
 363         todaysdate              => format_date($todaysdate),
 364         overdueloop             => \@overduedata,
 365         nnoverdue               => scalar(@overduedata),
 366         noverdue_is_plural      => scalar(@overduedata) != 1,
 367         noreport                => $noreport,
 368         isfiltered              => $isfiltered,
 369         borflag_gonenoaddress   => $borflagsfilter eq 'gonenoaddress',
 370         borflag_debarred        => $borflagsfilter eq 'debarred',
 371         borflag_lost            => $borflagsfilter eq 'lost',
 372     );
 373
 374 }
 375
 376 output_html_with_http_headers $input, $cookie, $template->output;
 377
 378
 379 sub build_csv {
 380     my $overdues = shift;
 381
 382     return "" if scalar(@$overdues) == 0;
 383
 384     my @lines = ();
 385
 386     # build header ...
 387     my @keys = grep { $_ ne 'patron_attr_value_loop' } sort keys %{ $overdues->[0] };
 388     my $csv = Text::CSV_XS->new();
 389     $csv->combine(@keys);
 390     push @lines, $csv->string();
 391
 392     # ... and rest of report
 393     foreach my $overdue ( @{ $overdues } ) {
 394         push @lines, $csv->string() if $csv->combine(map { $overdue->{$_} } @keys);
 395     }
 396
 397     return join("\n", @lines) . "\n";
 398 }