Updating perlcriticrc to allow Modern::Perl to suffice instead of use warnings; and...
[koha.git] / reports / acquisitions_stats.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 # test comment
22
23 use strict;
24 #use warnings; FIXME - Bug 2505
25 use C4::Auth;
26 use CGI;
27 use C4::Context;
28 use C4::Reports;
29 use C4::Output;
30 use C4::Koha;
31 use C4::Circulation;
32 use C4::Dates qw/format_date format_date_in_iso/;
33
34 =head1 NAME
35
36 plugin that shows a stats on borrowers
37
38 =head1 DESCRIPTION
39
40 =over 2
41
42 =cut
43
44 my $input          = new CGI;
45 my $do_it          = $input->param('do_it');
46 my $fullreportname = "reports/acquisitions_stats.tmpl";
47 my $line           = $input->param("Line");
48 my $column         = $input->param("Column");
49 my @filters        = $input->param("Filter");
50 $filters[0] = format_date_in_iso( $filters[0] );
51 $filters[1] = format_date_in_iso( $filters[1] );
52 $filters[2] = format_date_in_iso( $filters[2] );
53 $filters[3] = format_date_in_iso( $filters[3] );
54 my $podsp          = $input->param("PlacedOnDisplay");
55 my $rodsp          = $input->param("ReceivedOnDisplay");
56 my $aodsp          = $input->param("AcquiredOnDisplay");    ##added by mason.
57 my $calc           = $input->param("Cellvalue");
58 my $output         = $input->param("output");
59 my $basename       = $input->param("basename");
60
61 my ($template, $borrowernumber, $cookie)
62         = get_template_and_user({template_name => $fullreportname,
63                                 query => $input,
64                                 type => "intranet",
65                                 authnotrequired => 0,
66                                 flagsrequired => {reports => '*'},
67                                 debug => 1,
68                                 });
69 our $sep     = $input->param("sep");
70 $sep = "\t" if ($sep eq 'tabulation');
71 $template->param(do_it => $do_it,
72         DHTMLcalendar_dateformat => C4::Dates->DHTMLcalendar(),
73                 );
74 if ($do_it) {
75     my $results =
76       calculate( $line, $column, $podsp, $rodsp, $aodsp, $calc, \@filters );
77     if ( $output eq "screen" ) {
78         $template->param( mainloop => $results );
79         output_html_with_http_headers $input, $cookie, $template->output;
80     }
81     else {
82         print $input->header(
83             -type       => 'application/vnd.sun.xml.calc',
84             -encoding    => 'utf-8',
85             -attachment => "$basename.csv",
86             -name       => "$basename.csv"
87         );
88         my $cols  = @$results[0]->{loopcol};
89         my $lines = @$results[0]->{looprow};
90         print @$results[0]->{line} . "/" . @$results[0]->{column} . $sep;
91         foreach my $col (@$cols) {
92             print $col->{coltitle} . $sep;
93         }
94         print "Total\n";
95         foreach my $line (@$lines) {
96             my $x = $line->{loopcell};
97             print $line->{rowtitle} . $sep;
98             foreach my $cell (@$x) {
99                 print $cell->{value} . $sep;
100             }
101             print $line->{totalrow};
102             print "\n";
103         }
104         print "TOTAL";
105         $cols = @$results[0]->{loopfooter};
106         foreach my $col (@$cols) {
107             print $sep. $col->{totalcol};
108         }
109         print $sep. @$results[0]->{total};
110     }
111     exit(1);
112 }
113 else {
114     my $dbh = C4::Context->dbh;
115     my @select;
116     my %select;
117     my $req;
118     $req = $dbh->prepare("SELECT distinctrow id,name FROM aqbooksellers ORDER BY name");
119     $req->execute;
120     my @select;
121     push @select, "";
122         $select{''} = "All Suppliers";
123     while ( my ( $value, $desc ) = $req->fetchrow ) {
124         push @select, $desc;
125         $select{$value}=$desc;
126     }
127     my $CGIBookSellers = CGI::scrolling_list(
128         -name   => 'Filter',
129         -id     => 'supplier',
130         -values => \@select,
131         -labels   => \%select,
132         -size     => 1,
133         -multiple => 0
134     );
135
136     $req = $dbh->prepare("SELECT DISTINCTROW itemtype,description FROM itemtypes ORDER BY description");
137     $req->execute;
138     undef @select;
139     undef %select;
140     push @select, "";
141     $select{''} = "All Item Types";
142     while ( my ( $value, $desc ) = $req->fetchrow ) {
143         push @select, $value;
144         $select{$value} = $desc;
145     }
146     my $CGIItemTypes = CGI::scrolling_list(
147         -name     => 'Filter',
148         -id       => 'itemtypes',
149         -values   => \@select,
150         -labels   => \%select,
151         -size     => 1,
152         -multiple => 0
153     );
154
155     $req = $dbh->prepare("SELECT DISTINCTROW budget_code, budget_name FROM aqbudgets ORDER BY budget_name");
156     $req->execute;
157     undef @select;
158     undef %select;
159     push @select, "";
160     $select{''} = "All budgets";
161
162     while ( my ( $value, $desc ) = $req->fetchrow ) {
163         push @select, $value;
164         $select{$value} = $desc;
165     }
166     my $CGIBudget = CGI::scrolling_list(
167         -name     => 'Filter',
168         -id       => 'budget',
169         -values   => \@select,
170         -labels   => \%select,
171         -size     => 1,
172         -multiple => 0
173     );
174
175     $req =
176       $dbh->prepare(
177 "SELECT DISTINCTROW sort1 FROM aqorders WHERE sort1 IS NOT NULL ORDER BY sort1"
178       );
179     $req->execute;
180     undef @select;
181     undef %select;
182     push @select, "";
183     $select{''} = "All";
184     my $hassort1;
185     while ( my ($value) = $req->fetchrow ) {
186                 if ($value) {
187                         $hassort1 = 1;
188                         push @select, $value;
189                         $select{$value} = $value;
190                 }
191     }
192     my $CGISort1 = CGI::scrolling_list(
193         -name     => 'Filter',
194         -id       => 'sort1',
195         -values   => \@select,
196         -labels   => \%select,
197         -size     => 1,
198         -multiple => 0
199     );
200
201     $req =
202       $dbh->prepare(
203 "SELECT DISTINCTROW sort2 FROM aqorders WHERE sort2 IS NOT NULL ORDER BY sort2"
204       );
205     $req->execute;
206     undef @select;
207     undef %select;
208     push @select, "";
209     $select{''} = "All";
210     my $hassort2;
211     my $hglghtsort2;
212
213     while ( my ($value) = $req->fetchrow ) {
214                 if ($value) {
215                         $hassort2 = 1;
216                         $hglghtsort2 = !($hassort1);
217                         push @select, $value;
218                         $select{$value} = $value;
219                 }
220     }
221     my $CGISort2 = CGI::scrolling_list(
222         -name     => 'Filter',
223         -id       => 'sort2',
224         -values   => \@select,
225         -labels   => \%select,
226         -size     => 1,
227         -multiple => 0
228     );
229
230     my $CGIextChoice = CGI::scrolling_list(
231         -name     => 'MIME',
232         -id       => 'MIME',
233         -values   => ['CSV'], # FIXME translation
234         -size     => 1,
235         -multiple => 0
236     );
237
238     my $CGIsepChoice = GetDelimiterChoices;
239
240     $template->param(
241         CGIBookSeller => $CGIBookSellers,
242         CGIItemType   => $CGIItemTypes,
243         CGIBudget     => $CGIBudget,
244         hassort1      => $hassort1,
245         hassort2      => $hassort2,
246         HlghtSort2    => $hglghtsort2,
247         CGISort1      => $CGISort1,
248         CGISort2      => $CGISort2,
249         CGIextChoice  => $CGIextChoice,
250         CGIsepChoice  => $CGIsepChoice,
251                 date_today => C4::Dates->new()->output()
252     );
253
254 }
255 output_html_with_http_headers $input, $cookie, $template->output;
256
257 sub calculate {
258     my ( $line, $column, $podsp, $rodsp, $aodsp, $process, $filters ) = @_;
259     my @mainloop;
260     my @loopfooter;
261     my @loopcol;
262     my @loopline;
263     my @looprow;
264     my %globalline;
265     my $grantotal = 0;
266
267     # extract parameters
268     my $dbh = C4::Context->dbh;
269
270     # Filters
271     # Checking filters
272     #
273     my @loopfilter;
274     for ( my $i = 0 ; $i <= 8 ; $i++ ) {
275         my %cell;
276         if ( @$filters[$i] ) {
277             if ( ( ( $i == 1 ) or ( $i == 3 ) ) and ( @$filters[ $i - 1 ] ) ) {
278                 $cell{err} = 1 if ( @$filters[$i] < @$filters[ $i - 1 ] );
279             }
280             # format the dates filters, otherwise just fill as is
281             if ($i>=4) {
282                 $cell{filter} .= @$filters[$i];
283             } else {
284                 $cell{filter} .= format_date(@$filters[$i]);
285             }
286             $cell{crit}   .= "Placed On From" if ( $i == 0 );
287             $cell{crit}   .= "Placed On To" if ( $i == 1 );
288             $cell{crit}   .= "Received On From" if ( $i == 2 );
289             $cell{crit}   .= "Received On To" if ( $i == 3 );
290
291 #            $cell{crit} .= "Acquired On From" if ( $i == 4 );
292 #            $cell{crit} .= "Acquired On To"   if ( $i == 5 );
293
294             $cell{crit} .= "BookSeller" if ( $i == 4 );
295             $cell{crit} .= "Doc Type"   if ( $i == 5 );
296             $cell{crit} .= "Budget"     if ( $i == 6 );
297             $cell{crit} .= "Sort1"      if ( $i == 7 );
298             $cell{crit} .= "Sort2"      if ( $i == 8 );
299             push @loopfilter, \%cell;
300         }
301     }
302
303     my @linefilter;
304
305     $linefilter[0] = @$filters[0] if ( $line =~ /closedate/ );
306     $linefilter[1] = @$filters[1] if ( $line =~ /closedate/ );
307     $linefilter[0] = @$filters[2] if ( $line =~ /received/ );
308     $linefilter[1] = @$filters[3] if ( $line =~ /received/ );
309
310     $linefilter[0] = @$filters[4]  if ( $line =~ /bookseller/ );
311     $linefilter[0] = @$filters[5]  if ( $line =~ /itemtype/ );
312     $linefilter[0] = @$filters[6]  if ( $line =~ /budget/ );
313     $linefilter[0] = @$filters[7]  if ( $line =~ /sort1/ );
314     $linefilter[0] = @$filters[8] if ( $line =~ /sort2/ );
315
316     my @colfilter;
317     $colfilter[0] = @$filters[0] if ( $column =~ /closedate/ );
318     $colfilter[1] = @$filters[1] if ( $column =~ /closedate/ );
319     $colfilter[0] = @$filters[2] if ( $column =~ /received/ );
320     $colfilter[1] = @$filters[3] if ( $column =~ /received/ );
321
322     $colfilter[0] = @$filters[4]  if ( $column =~ /bookseller/ );
323     $colfilter[0] = @$filters[5]  if ( $column =~ /itemtype/ );
324     $colfilter[0] = @$filters[6]  if ( $column =~ /budget/ );
325     $colfilter[0] = @$filters[7]  if ( $column =~ /sort1/ );
326     $colfilter[0] = @$filters[8]  if ( $column =~ /sort2/ );
327
328     # 1st, loop rows.
329     my $linefield;
330     if ( ( $line =~ /closedate/ ) and ( $podsp == 1 ) ) {
331
332         #Display by day
333         $linefield .= "concat(hex(weekday($line)+1),'-',dayname($line))";
334     }
335     elsif ( ( $line =~ /closedate/ ) and ( $podsp == 2 ) ) {
336
337         #Display by Month
338         $linefield .= "concat(hex(month($line)),'-',monthname($line))";
339     }
340     elsif ( ( $line =~ /closedate/ ) and ( $podsp == 3 ) ) {
341
342         #Display by Year
343         $linefield .= "Year($line)";
344
345     }
346     elsif ( ( $line =~ /received/ ) and ( $rodsp == 1 ) ) {
347
348         #Display by day
349         $linefield .= "concat(hex(weekday($line)+1),'-',dayname($line))";
350     }
351     elsif ( ( $line =~ /received/ ) and ( $rodsp == 2 ) ) {
352
353         #Display by Month
354         $linefield .= "concat(hex(month($line)),'-',monthname($line))";
355     }
356     elsif ( ( $line =~ /received/ ) and ( $rodsp == 3 ) ) {
357
358         #Display by Year
359         $linefield .= "Year($line)";
360
361     }
362     else {
363         $linefield .= $line;
364     }
365
366     my $strsth;
367     $strsth .=
368       "SELECT DISTINCTROW $linefield FROM (aqorders, aqbasket )
369                 LEFT JOIN items ON (aqorders.biblionumber= items.biblionumber)
370                 LEFT JOIN biblioitems ON (aqorders.biblionumber= biblioitems.biblionumber)
371                 LEFT JOIN aqbudgets  ON (aqorders.budget_id = aqbudgets.budget_id )
372
373                 LEFT JOIN aqbooksellers ON (aqbasket.booksellerid=aqbooksellers.id) WHERE (aqorders.basketno=aqbasket.basketno)
374                 AND $line IS NOT NULL AND $line <> '' ";
375     
376         if (@linefilter) {
377         if ( $linefilter[1] ) {
378             if ( $linefilter[0] ) {
379                 $strsth .= " AND $line BETWEEN ? AND ? ";
380             }
381             else {
382                 $strsth .= " AND $line <= ? ";
383             }
384         }
385         elsif (
386             ( $linefilter[0] )
387             and (  ( $line =~ /closedate/ )
388                 or ( $line =~ /received/ ))
389           )
390         {
391             $strsth .= " AND $line >= ? ";
392         }
393         elsif ( $linefilter[0] ) {
394             $linefilter[0] =~ s/\*/%/g;
395             $strsth .= " AND $line LIKE ? ";
396         }
397     }
398     $strsth .= " GROUP BY $linefield";
399     $strsth .= " ORDER BY $line";
400
401     my $sth = $dbh->prepare($strsth);
402     if ( (@linefilter) and ( $linefilter[1] ) ) {
403         $sth->execute( $linefilter[0], $linefilter[1] );
404     }
405     elsif ( $linefilter[0] ) {
406         $sth->execute( $linefilter[0] );
407     }
408     else {
409         $sth->execute;
410     }
411         while ( my ($celvalue) = $sth->fetchrow ) {
412                 my %cell;
413                 if ($celvalue) {
414                         $cell{rowtitle} = $celvalue;
415                         push @loopline, \%cell;
416                 }
417                 $cell{totalrow} = 0;
418         }
419     # 2nd, loop cols.
420     my $colfield;
421     if ( ( $column =~ /closedate/ ) and ( $podsp == 1 ) ) {
422
423         #Display by day
424         $colfield .= "concat(hex(weekday($column)+1),'-',dayname($column))";
425     }
426     elsif ( ( $column =~ /closedate/ ) and ( $podsp == 2 ) ) {
427
428         #Display by Month
429         $colfield .= "concat(hex(month($column)),'-',monthname($column))";
430     }
431     elsif ( ( $column =~ /closedate/ ) and ( $podsp == 3 ) ) {
432
433         #Display by Year
434         $colfield .= "Year($column)";
435
436     }
437     elsif ( ( $column =~ /received/ ) and ( $rodsp == 1 ) ) {
438
439         #Display by day
440         $colfield .= "concat(hex(weekday($column)+1),'-',dayname($column))";
441     }
442     elsif ( ( $column =~ /received/ ) and ( $rodsp == 2 ) ) {
443
444         #Display by Month
445         $colfield .= "concat(hex(month($column)),'-',monthname($column))";
446     }
447     elsif ( ( $column =~ /received/ ) and ( $rodsp == 3 ) ) {
448
449         #Display by Year
450         $colfield .= "Year($column)";
451
452     }
453     else {
454         $colfield .= $column;
455     }
456
457     my $strsth2;
458     $strsth2 .=
459       "SELECT distinctrow $colfield FROM (aqorders, aqbasket )
460                  LEFT JOIN items ON (aqorders.biblionumber= items.biblionumber)
461                  LEFT JOIN biblioitems ON (aqorders.biblionumber= biblioitems.biblionumber)
462                  LEFT JOIN aqbudgets  ON (aqorders.budget_id = aqbudgets.budget_id )
463
464                  LEFT JOIN aqbooksellers ON (aqbasket.booksellerid=aqbooksellers.id)
465                  WHERE (aqorders.basketno=aqbasket.basketno) AND 
466                  $column IS NOT NULL AND $column <> '' ";
467
468     if (@colfilter) {
469         if ( $colfilter[1] ) {
470             if ( $colfilter[0] ) {
471                 $strsth2 .= " AND $column BETWEEN  ? AND ? ";
472             }
473             else {
474                 $strsth2 .= " AND $column <= ? ";
475             }
476         }
477         elsif (
478             ( $colfilter[0] )
479             and (  ( $column =~ /closedate/ )
480                 or ( $line =~ /received/ ))
481           )
482         {
483             $strsth2 .= " AND $column >= ? ";
484         }
485         elsif ( $colfilter[0] ) {
486             $colfilter[0] =~ s/\*/%/g;
487             $strsth2 .= " AND $column LIKE ? ";
488         }
489     }
490
491
492     $strsth2 .= " GROUP BY $colfield";
493     $strsth2 .= " ORDER BY $colfield";
494
495     my $sth2 = $dbh->prepare($strsth2);
496
497     if ( (@colfilter) and ($colfilter[1]) ) {
498         $sth2->execute( $colfilter[0], $colfilter[1] );
499     }
500     elsif ( $colfilter[0] ) {
501         $sth2->execute( $colfilter[0] );
502     }
503     else {
504         $sth2->execute;
505     }
506         while ( my $celvalue = $sth2->fetchrow ) {
507                 my %cell;
508                 if ($celvalue) {
509                         $cell{coltitle} = $celvalue;
510                         push @loopcol, \%cell;
511                 }
512         }
513
514     my $i = 0;
515     my @totalcol;
516     my $hilighted = -1;
517
518     #Initialization of cell values.....
519     my %table;
520
521     foreach my $row (@loopline) {
522         foreach my $col (@loopcol) {
523             $table{ $row->{rowtitle} }->{ $col->{coltitle} } = 0;
524         }
525         $table{ $row->{rowtitle} }->{totalrow} = 0;
526     }
527
528     # preparing calculation
529     my $strcalc;
530     $strcalc .= "SELECT $linefield, $colfield, ";
531     $strcalc .= "SUM( aqorders.quantity ) " if ( $process == 1 );
532     $strcalc .= "SUM( aqorders.quantity * aqorders.listprice ) "
533       if ( $process == 2 );
534     $strcalc .= "FROM (aqorders, aqbasket )
535                  LEFT JOIN items ON (aqorders.biblionumber= items.biblionumber)
536                  LEFT JOIN biblioitems ON (aqorders.biblionumber= biblioitems.biblionumber)
537                  LEFT JOIN aqbudgets  ON (aqorders.budget_id = aqbudgets.budget_id )
538
539                  LEFT JOIN aqbooksellers ON (aqbasket.booksellerid=aqbooksellers.id) 
540                  WHERE (aqorders.basketno=aqbasket.basketno) ";
541     
542         @$filters[0] =~ s/\*/%/g if ( @$filters[0] );
543     $strcalc .= " AND aqbasket.closedate >= '" . @$filters[0] . "'"
544       if ( @$filters[0] );
545     @$filters[1] =~ s/\*/%/g if ( @$filters[1] );
546     $strcalc .= " AND aqbasket.closedate <= '" . @$filters[1] . "'"
547       if ( @$filters[1] );
548     @$filters[2] =~ s/\*/%/g if ( @$filters[2] );
549     $strcalc .= " AND aqorders.datereceived >= '" . @$filters[2] . "'"
550       if ( @$filters[2] );
551     @$filters[3] =~ s/\*/%/g if ( @$filters[3] );
552     $strcalc .= " AND aqorders.datereceived <= '" . @$filters[3] . "'"
553       if ( @$filters[3] );
554     @$filters[4] =~ s/\*/%/g if ( @$filters[4] );
555     $strcalc .= " AND aqbooksellers.name LIKE '" . @$filters[4] . "'"
556       if ( @$filters[4] );
557     @$filters[5] =~ s/\*/%/g if ( @$filters[5] );
558     $strcalc .= " AND biblioitems.itemtype LIKE '" . @$filters[5] . "'"
559       if ( @$filters[5] );
560     @$filters[6] =~ s/\*/%/g if ( @$filters[6] );
561     $strcalc .= " AND aqbudgets.budget_code LIKE '" . @$filters[6] . "'"
562       if ( @$filters[6] );
563     @$filters[7] =~ s/\*/%/g if ( @$filters[7] );
564     $strcalc .= " AND aqorders.sort1 LIKE '" . @$filters[7] . "'"
565       if ( @$filters[7] );
566     @$filters[8] =~ s/\*/%/g if ( @$filters[8] );
567     $strcalc .= " AND aqorders.sort2 LIKE '" . @$filters[8] . "'"
568       if ( @$filters[8] );
569
570     $strcalc .= " AND aqorders.datecancellationprinted is NULL ";
571
572     $strcalc .= " GROUP BY $linefield, $colfield ORDER BY $linefield,$colfield";
573     my $dbcalc = $dbh->prepare($strcalc);
574     $dbcalc->execute;
575
576     my $emptycol;
577     while ( my ( $row, $col, $value ) = $dbcalc->fetchrow ) {
578                 next if ($row eq undef || $col eq undef);
579
580         $emptycol = 1         if ( !defined($col) );
581         $col      = "zzEMPTY" if ( !defined($col) );
582         $row      = "zzEMPTY" if ( !defined($row) );
583
584         $table{$row}->{$col}     += $value;
585         $table{$row}->{totalrow} += $value;
586         $grantotal               += $value;
587     }
588
589     push @loopcol, { coltitle => "NULL" } if ($emptycol);
590
591     foreach my $row ( sort keys %table ) {
592         my @loopcell;
593         #@loopcol ensures the order for columns is common with column titles
594         # and the number matches the number of columns
595         foreach my $col (@loopcol) {
596             my $value = $table{$row}->{ ( $col->{coltitle} eq "NULL" ) ? "zzEMPTY" : $col->{coltitle} };
597             push @loopcell, { value => $value };
598         }
599         push @looprow,
600           {
601             'rowtitle' => ( $row eq "zzEMPTY" ) ? "NULL" : $row,
602             'loopcell'  => \@loopcell,
603             'hilighted' => ( $hilighted > 0 ),
604             'totalrow'  => $table{$row}->{totalrow}
605           };
606         $hilighted = -$hilighted;
607     }
608
609     foreach my $col (@loopcol) {
610         my $total = 0;
611         foreach my $row (@looprow) {
612             $total += $table{
613                 ( $row->{rowtitle} eq "NULL" ) ? "zzEMPTY"
614                 : $row->{rowtitle}
615               }->{
616                 ( $col->{coltitle} eq "NULL" ) ? "zzEMPTY"
617                 : $col->{coltitle}
618               };
619         }
620
621         push @loopfooter, { 'totalcol' => $total };
622     }
623
624     # the header of the table
625         $globalline{loopfilter}=\@loopfilter;
626     # the core of the table
627     $globalline{looprow} = \@looprow;
628     $globalline{loopcol} = \@loopcol;
629
630     #       # the foot (totals by borrower type)
631     $globalline{loopfooter} = \@loopfooter;
632     $globalline{total}      = $grantotal;
633     $globalline{line}       = $line;
634     $globalline{column}     = $column;
635     push @mainloop, \%globalline;
636     return \@mainloop;
637 }
638
639 1;
640