circ/overdue.pl

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