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 (0 && @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     branchloop   => GetBranchesLoop($branchfilter, $onlymine),
 204     branchfilter => $branchfilter,
 205     borcatloop=> \@borcatloop,
 206     itemtypeloop => \@itemtypeloop,
 207 #     patron_attr_filter_loop => \@patron_attr_filter_loop,
 208     borname => $bornamefilter,
 209     order => $order,
 210     showall => $showall);
 211
 212 if ($noreport) {
 213     # la de dah ... page comes up presto-quicko
 214     $template->param( noreport  => $noreport );
 215 } else {
 216     # FIXME : the left joins + where clauses make the following SQL query really slow with large datasets :(
 217     #
 218     #  FIX 1: use the table with the least rows as first in the join, second least second, etc
 219     #         ref: http://www.fiftyfoureleven.com/weblog/web-development/programming-and-scripts/mysql-optimization-tip
 220     #
 221     #  FIX 2: ensure there are indexes for columns participating in the WHERE clauses, where feasible/reasonable
 222
 223
 224     my $todaysdate = sprintf("%-04.4d-%-02.2d-%02.2d", Today());
 225
 226     $bornamefilter =~s/\*/\%/g;
 227     $bornamefilter =~s/\?/\_/g;
 228
 229     my $strsth="SELECT date_due,
 230         concat(surname,' ', firstname) as borrower,
 231         borrowers.phone,
 232         borrowers.email,
 233         issues.itemnumber,
 234         items.barcode,
 235         biblio.title,
 236         biblio.author,
 237         borrowers.borrowernumber,
 238         biblio.biblionumber,
 239         borrowers.branchcode,
 240         items.itemcallnumber,
 241         items.replacementprice
 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     $strsth.=" AND biblioitems.itemtype   = '" . $itemtypefilter . "' " if $itemtypefilter;
 253     $strsth.=" AND borrowers.flags        = '" . $borflagsfilter . "' " if $borflagsfilter;
 254     $strsth.=" AND borrowers.branchcode   = '" . $branchfilter   . "' " if $branchfilter;
 255     # restrict patrons (borrowers) to those matching the patron attribute filter(s), if any
 256     my $bnlist = $have_pattr_filter_data ? join(',',keys %borrowernumber_to_attributes) : '';
 257     $strsth =~ s/WHERE 1=1/WHERE 1=1 AND borrowers.borrowernumber IN ($bnlist)/ if $bnlist;
 258     $strsth =~ s/WHERE 1=1/WHERE 0=1/ if $have_pattr_filter_data  && !$bnlist;  # no match if no borrowers matched patron attrs
 259     $strsth.=" ORDER BY " . (
 260         ($order eq "borrower" or $order eq "borrower desc") ? "$order, date_due"                 :
 261         ($order eq "title"    or $order eq    "title desc") ? "$order, date_due, borrower"       :
 262         ($order eq "barcode"  or $order eq  "barcode desc") ? "items.$order, date_due, borrower" :
 263                                 ($order eq "date_due desc") ? "date_due DESC, borrower"          :
 264                                                             "date_due, borrower"  # default sort order
 265     );
 266     $template->param(sql=>$strsth);
 267     my $sth=$dbh->prepare($strsth);
 268     #warn "overdue.pl : query string ".$strsth;
 269     $sth->execute();
 270
 271     my @overduedata;
 272     while (my $data = $sth->fetchrow_hashref) {
 273
 274         # most of the overdue report data is linked to the database schema, i.e. things like borrowernumber and phone
 275         # but the patron attributes (patron_attr_value_loop) are unnormalised and varies dynamically from one db to the next
 276
 277         my $pattrs = $borrowernumber_to_attributes{$data->{borrowernumber}} || {};  # patron attrs for this borrower
 278         # $pattrs is a hash { attrcode => [  [value,displayvalue], [value,displayvalue]... ] }
 279
 280         my @patron_attr_value_loop;   # template array [ {value=>v1}, {value=>v2} ... } ]
 281         for my $pattr_filter (grep { ! $_->{isclone} } @patron_attr_filter_loop) {
 282             my @displayvalues = map { $_->[1] } @{ $pattrs->{$pattr_filter->{code}} };   # grab second value from each subarray
 283             push @patron_attr_value_loop, { value => join(', ', sort { lc $a cmp lc $b } @displayvalues) };
 284         }
 285
 286         push @overduedata, {
 287             duedate                => format_date($data->{date_due}),
 288             borrowernumber         => $data->{borrowernumber},
 289             barcode                => $data->{barcode},
 290             itemnum                => $data->{itemnumber},
 291             name                   => $data->{borrower},
 292             phone                  => $data->{phone},
 293             email                  => $data->{email},
 294             biblionumber           => $data->{biblionumber},
 295             title                  => $data->{title},
 296             author                 => $data->{author},
 297             branchcode             => $data->{branchcode},
 298             itemcallnumber         => $data->{itemcallnumber},
 299             replacementprice       => $data->{replacementprice},
 300             patron_attr_value_loop => \@patron_attr_value_loop,
 301         };
 302     }
 303
 304     my ($attrorder) = $order =~ /patron_attr_(.*)$/;
 305     my $patrorder = '';
 306     my $sortorder = 'asc';
 307     if (defined $attrorder) {
 308         ($sortorder, $patrorder) = split /_/, $attrorder, 2;
 309     }
 310     print STDERR ">>> order is $order, patrorder is $patrorder, sortorder is $sortorder\n" if $debug;
 311
 312     if (my @attrtype = grep { $_->{'code'} eq $patrorder } @patron_attr_filter_loop) {        # sort by patron attrs perhaps?
 313         my $ordinal = $attrtype[0]{ordinal};
 314         print STDERR ">>> sort ordinal is $ordinal\n" if $debug;
 315
 316         sub patronattr_sorter_asc {
 317             lc $a->{patron_attr_value_loop}[$ordinal]{value}
 318             cmp
 319             lc $b->{patron_attr_value_loop}[$ordinal]{value} }
 320
 321         sub patronattr_sorter_des { -patronattr_sorter_asc() }
 322
 323         my $sorter = $sortorder eq 'desc' ? \&patronattr_sorter_des : \&patronattr_sorter_asc;
 324         @overduedata = sort $sorter @overduedata;
 325     }
 326
 327     if ($op eq 'csv') {
 328         binmode(STDOUT, ":utf8");
 329         my $csv = build_csv(\@overduedata);
 330         print $input->header(-type => 'application/vnd.sun.xml.calc',
 331                              -encoding    => 'utf-8',
 332                              -attachment=>"overdues.csv",
 333                              -filename=>"overdues.csv" );
 334         print $csv;
 335         exit;
 336     }
 337
 338     # generate parameter list for CSV download link
 339     my $new_cgi = CGI->new($input);
 340     $new_cgi->delete('op');
 341     my $csv_param_string = $new_cgi->query_string();
 342
 343     $template->param(
 344         csv_param_string        => $csv_param_string,
 345         todaysdate              => format_date($todaysdate),
 346         overdueloop             => \@overduedata,
 347         nnoverdue               => scalar(@overduedata),
 348         noverdue_is_plural      => scalar(@overduedata) != 1,
 349         noreport                => $noreport,
 350         isfiltered              => $isfiltered,
 351         borflag_gonenoaddress   => $borflagsfilter eq 'gonenoaddress',
 352         borflag_debarred        => $borflagsfilter eq 'debarred',
 353         borflag_lost            => $borflagsfilter eq 'lost',
 354     );
 355
 356 }
 357
 358 output_html_with_http_headers $input, $cookie, $template->output;
 359
 360
 361 sub build_csv {
 362     my $overdues = shift;
 363
 364     return "" if scalar(@$overdues) == 0;
 365
 366     my @lines = ();
 367
 368     # build header ...
 369     my @keys = grep { $_ ne 'patron_attr_value_loop' } sort keys %{ $overdues->[0] };
 370     my $csv = Text::CSV_XS->new();
 371     $csv->combine(@keys);
 372     push @lines, $csv->string();
 373
 374     # ... and rest of report
 375     foreach my $overdue ( @{ $overdues } ) {
 376         push @lines, $csv->string() if $csv->combine(map { $overdue->{$_} } @keys);
 377     }
 378
 379     return join("\n", @lines) . "\n";
 380 }