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
  18 # with Koha; if not, write to the Free Software Foundation, Inc.,
  19 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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         borrowers.title as borrowertitle,
 232         concat(surname,' ', firstname) as borrower,
 233         borrowers.streetnumber,
 234         borrowers.streettype,
 235         borrowers.address,
 236         borrowers.address2,
 237         borrowers.city,
 238         borrowers.zipcode,
 239         borrowers.country,
 240         borrowers.phone,
 241         borrowers.email,
 242         issues.itemnumber,
 243         items.barcode,
 244         biblio.title,
 245         biblio.author,
 246         borrowers.borrowernumber,
 247         biblio.biblionumber,
 248         borrowers.branchcode,
 249         items.itemcallnumber,
 250         items.replacementprice
 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     $strsth.=" AND biblioitems.itemtype   = '" . $itemtypefilter . "' " if $itemtypefilter;
 262     $strsth.=" AND borrowers.flags        = '" . $borflagsfilter . "' " if $borflagsfilter;
 263     $strsth.=" AND borrowers.branchcode   = '" . $branchfilter   . "' " if $branchfilter;
 264     # restrict patrons (borrowers) to those matching the patron attribute filter(s), if any
 265     my $bnlist = $have_pattr_filter_data ? join(',',keys %borrowernumber_to_attributes) : '';
 266     $strsth =~ s/WHERE 1=1/WHERE 1=1 AND borrowers.borrowernumber IN ($bnlist)/ if $bnlist;
 267     $strsth =~ s/WHERE 1=1/WHERE 0=1/ if $have_pattr_filter_data  && !$bnlist;  # no match if no borrowers matched patron attrs
 268     $strsth.=" ORDER BY " . (
 269         ($order eq "borrower" or $order eq "borrower desc") ? "$order, date_due"                 :
 270         ($order eq "title"    or $order eq    "title desc") ? "$order, date_due, borrower"       :
 271         ($order eq "barcode"  or $order eq  "barcode desc") ? "items.$order, date_due, borrower" :
 272                                 ($order eq "date_due desc") ? "date_due DESC, borrower"          :
 273                                                             "date_due, borrower"  # default sort order
 274     );
 275     $template->param(sql=>$strsth);
 276     my $sth=$dbh->prepare($strsth);
 277     #warn "overdue.pl : query string ".$strsth;
 278     $sth->execute();
 279
 280     my @overduedata;
 281     while (my $data = $sth->fetchrow_hashref) {
 282
 283         # most of the overdue report data is linked to the database schema, i.e. things like borrowernumber and phone
 284         # but the patron attributes (patron_attr_value_loop) are unnormalised and varies dynamically from one db to the next
 285
 286         my $pattrs = $borrowernumber_to_attributes{$data->{borrowernumber}} || {};  # patron attrs for this borrower
 287         # $pattrs is a hash { attrcode => [  [value,displayvalue], [value,displayvalue]... ] }
 288
 289         my @patron_attr_value_loop;   # template array [ {value=>v1}, {value=>v2} ... } ]
 290         for my $pattr_filter (grep { ! $_->{isclone} } @patron_attr_filter_loop) {
 291             my @displayvalues = map { $_->[1] } @{ $pattrs->{$pattr_filter->{code}} };   # grab second value from each subarray
 292             push @patron_attr_value_loop, { value => join(', ', sort { lc $a cmp lc $b } @displayvalues) };
 293         }
 294
 295         push @overduedata, {
 296             duedate                => format_date($data->{date_due}),
 297             borrowernumber         => $data->{borrowernumber},
 298             barcode                => $data->{barcode},
 299             itemnum                => $data->{itemnumber},
 300             borrowertitle          => $data->{borrowertitle},
 301             name                   => $data->{borrower},
 302             streetnumber           => $data->{streetnumber},
 303             streettype             => $data->{streettype},
 304             address                => $data->{address},
 305             address2               => $data->{address2},
 306             city                   => $data->{city},
 307             zipcode                => $data->{zipcode},
 308             country                => $data->{country},
 309             phone                  => $data->{phone},
 310             email                  => $data->{email},
 311             biblionumber           => $data->{biblionumber},
 312             title                  => $data->{title},
 313             author                 => $data->{author},
 314             branchcode             => $data->{branchcode},
 315             itemcallnumber         => $data->{itemcallnumber},
 316             replacementprice       => $data->{replacementprice},
 317             patron_attr_value_loop => \@patron_attr_value_loop,
 318         };
 319     }
 320
 321     my ($attrorder) = $order =~ /patron_attr_(.*)$/;
 322     my $patrorder = '';
 323     my $sortorder = 'asc';
 324     if (defined $attrorder) {
 325         ($sortorder, $patrorder) = split /_/, $attrorder, 2;
 326     }
 327     print STDERR ">>> order is $order, patrorder is $patrorder, sortorder is $sortorder\n" if $debug;
 328
 329     if (my @attrtype = grep { $_->{'code'} eq $patrorder } @patron_attr_filter_loop) {        # sort by patron attrs perhaps?
 330         my $ordinal = $attrtype[0]{ordinal};
 331         print STDERR ">>> sort ordinal is $ordinal\n" if $debug;
 332
 333         sub patronattr_sorter_asc {
 334             lc $a->{patron_attr_value_loop}[$ordinal]{value}
 335             cmp
 336             lc $b->{patron_attr_value_loop}[$ordinal]{value} }
 337
 338         sub patronattr_sorter_des { -patronattr_sorter_asc() }
 339
 340         my $sorter = $sortorder eq 'desc' ? \&patronattr_sorter_des : \&patronattr_sorter_asc;
 341         @overduedata = sort $sorter @overduedata;
 342     }
 343
 344     if ($op eq 'csv') {
 345         binmode(STDOUT, ":utf8");
 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     my $csv_param_string = $new_cgi->query_string();
 359
 360     $template->param(
 361         csv_param_string        => $csv_param_string,
 362         todaysdate              => format_date($todaysdate),
 363         overdueloop             => \@overduedata,
 364         nnoverdue               => scalar(@overduedata),
 365         noverdue_is_plural      => scalar(@overduedata) != 1,
 366         noreport                => $noreport,
 367         isfiltered              => $isfiltered,
 368         borflag_gonenoaddress   => $borflagsfilter eq 'gonenoaddress',
 369         borflag_debarred        => $borflagsfilter eq 'debarred',
 370         borflag_lost            => $borflagsfilter eq 'lost',
 371     );
 372
 373 }
 374
 375 output_html_with_http_headers $input, $cookie, $template->output;
 376
 377
 378 sub build_csv {
 379     my $overdues = shift;
 380
 381     return "" if scalar(@$overdues) == 0;
 382
 383     my @lines = ();
 384
 385     # build header ...
 386     my @keys = grep { $_ ne 'patron_attr_value_loop' } sort keys %{ $overdues->[0] };
 387     my $csv = Text::CSV_XS->new();
 388     $csv->combine(@keys);
 389     push @lines, $csv->string();
 390
 391     # ... and rest of report
 392     foreach my $overdue ( @{ $overdues } ) {
 393         push @lines, $csv->string() if $csv->combine(map { $overdue->{$_} } @keys);
 394     }
 395
 396     return join("\n", @lines) . "\n";
 397 }