minor bug fix in clark
[Evergreen.git] / Open-ILS / src / reporter / clark-kent.pl
1 #!/usr/bin/perl -w
2
3 use strict;
4 use diagnostics;
5 use DBI;
6 use FileHandle;
7 use XML::LibXML;
8 use Getopt::Long;
9 use DateTime;
10 use DateTime::Format::ISO8601;
11 use JSON;
12 use Data::Dumper;
13 use OpenILS::WWW::Reporter::transforms;
14 use Text::CSV_XS;
15 use Spreadsheet::WriteExcel;
16 use OpenSRF::EX qw/:try/;
17 use OpenSRF::Utils qw/:daemon/;
18 use OpenSRF::Utils::Logger qw/:level/;
19 use POSIX;
20 use GD::Graph::pie;
21 use GD::Graph::bars3d;
22 use GD::Graph::lines3d;
23
24 use open ':utf8';
25
26
27 my ($base_xml, $count, $daemon) = ('/openils/conf/reporter.xml', 1);
28
29 GetOptions(
30         "file=s"        => \$base_xml,
31         "daemon"        => \$daemon,
32         "concurrency=i" => \$count,
33 );
34
35 my $parser = XML::LibXML->new;
36 $parser->expand_xinclude(1);
37
38 my $doc = $parser->parse_file($base_xml);
39
40 my $db_driver = $doc->findvalue('/reporter/setup/database/driver');
41 my $db_host = $doc->findvalue('/reporter/setup/database/host');
42 my $db_port = $doc->findvalue('/reporter/setup/database/port') || '5432';
43 my $db_name = $doc->findvalue('/reporter/setup/database/name');
44 my $db_user = $doc->findvalue('/reporter/setup/database/user');
45 my $db_pw = $doc->findvalue('/reporter/setup/database/password');
46
47 my $dsn = "dbi:" . $db_driver . ":dbname=" . $db_name .';host=' . $db_host . ';port=' . $db_port;
48
49 my ($dbh,$running,$sth,@reports,$run, $current_time);
50
51 daemonize("Clark Kent, waiting for trouble") if ($daemon);
52
53 DAEMON:
54
55 $dbh = DBI->connect($dsn,$db_user,$db_pw, {pg_enable_utf8 => 1, RaiseError => 1});
56
57 $current_time = DateTime->from_epoch( epoch => time() )->strftime('%FT%T%z');
58 # Move new reports into the run queue
59 $dbh->do(<<'SQL', {}, $current_time);
60 INSERT INTO reporter.output ( stage3, state ) 
61         SELECT  id, 'wait'
62           FROM  reporter.stage3 
63           WHERE runtime <= $1
64                 AND (   (       recurrence = '0 seconds'::INTERVAL
65                                 AND (
66                                         id NOT IN ( SELECT stage3 FROM reporter.output )
67                                         OR rerun IS TRUE
68                                 )
69                         )
70                         OR (    recurrence > '0 seconds'::INTERVAL
71                                 AND id NOT IN (
72                                         SELECT  stage3
73                                           FROM  reporter.output
74                                           WHERE state <> 'complete')
75                         )
76                 )
77           ORDER BY runtime;
78 SQL
79
80 # make sure we're not already running $count reports
81 ($running) = $dbh->selectrow_array(<<SQL);
82 SELECT  count(*)
83   FROM  reporter.output
84   WHERE state = 'running';
85 SQL
86
87 if ($count <= $running) {
88         if ($daemon) {
89                 $dbh->disconnect;
90                 sleep 1;
91                 POSIX::waitpid( -1, POSIX::WNOHANG );
92                 sleep 60;
93                 goto DAEMON;
94         }
95         print "Already running maximum ($running) concurrent reports\n";
96         exit 1;
97 }
98
99 # if we have some open slots then generate the sql
100 $run = $count - $running;
101
102 $sth = $dbh->prepare(<<SQL);
103 SELECT  *
104   FROM  reporter.output
105   WHERE state = 'wait'
106   ORDER BY queue_time
107   LIMIT $run;
108 SQL
109
110 $sth->execute;
111
112 @reports = ();
113 while (my $r = $sth->fetchrow_hashref) {
114         my $s3 = $dbh->selectrow_hashref(<<"    SQL", {}, $r->{stage3});
115                 SELECT * FROM reporter.stage3 WHERE id = ?;
116         SQL
117
118         my $s2 = $dbh->selectrow_hashref(<<"    SQL", {}, $s3->{stage2});
119                 SELECT * FROM reporter.stage2 WHERE id = ?;
120         SQL
121
122         $s3->{stage2} = $s2;
123         $r->{stage3} = $s3;
124
125         generate_query( $r );
126         push @reports, $r;
127 }
128
129 $sth->finish;
130
131 $dbh->disconnect;
132
133 # Now we spaun the report runners
134
135 for my $r ( @reports ) {
136         next if (safe_fork());
137
138         # This is the child (runner) process;
139         my $p = JSON->JSON2perl( $r->{stage3}->{params} );
140         daemonize("Clark Kent reporting: $p->{reportname}");
141
142         $dbh = DBI->connect($dsn,$db_user,$db_pw, {pg_enable_utf8 => 1, RaiseError => 1});
143
144         try {
145                 $dbh->do(<<'            SQL',{}, $r->{sql}->{'select'}, $$, $r->{id});
146                         UPDATE  reporter.output
147                           SET   state = 'running',
148                                 run_time = 'now',
149                                 query = ?,
150                                 run_pid = ?
151                           WHERE id = ?;
152                 SQL
153
154                 my ($runtime) = $dbh->selectrow_array("SELECT run_time FROM reporter.output WHERE id = ?",{},$r->{id});
155                 $r->{run_time} = $runtime;
156
157                 $sth = $dbh->prepare($r->{sql}->{'select'});
158
159                 $sth->execute(@{ $r->{sql}->{'bind'} });
160                 $r->{data} = $sth->fetchall_arrayref;
161
162                 pivot_data($r);
163
164                 my $base = $doc->findvalue('/reporter/setup/files/output_base');
165                 my $s1 = $r->{stage3}->{stage2}->{stage1};
166                 my $s2 = $r->{stage3}->{stage2}->{id};
167                 my $s3 = $r->{stage3}->{id};
168                 my $output = $r->{id};
169
170                 mkdir($base);
171                 mkdir("$base/$s1");
172                 mkdir("$base/$s1/$s2");
173                 mkdir("$base/$s1/$s2/$s3");
174                 mkdir("$base/$s1/$s2/$s3/$output");
175         
176                 my @formats;
177                 if (ref $p->{output_format}) {
178                         @formats = @{ $p->{output_format} };
179                 } else {
180                         @formats = ( $p->{output_format} );
181                 }
182         
183                 if ( grep { $_ eq 'csv' } @formats ) {
184                         build_csv("$base/$s1/$s2/$s3/$output/report-data.csv", $r);
185                 }
186                 
187                 if ( grep { $_ eq 'excel' } @formats ) {
188                         build_excel("$base/$s1/$s2/$s3/$output/report-data.xls", $r);
189                 }
190                 
191                 if ( grep { $_ eq 'html' } @formats ) {
192                         mkdir("$base/$s1/$s2/$s3/$output/html");
193                         build_html("$base/$s1/$s2/$s3/$output/report-data.html", $r);
194                 }
195
196
197                 $dbh->begin_work;
198                 #$dbh->do(<<'           SQL',{}, $r->{run_time}, $r->{stage3}->{id});
199                 #       UPDATE  reporter.stage3
200                 #         SET   runtime = CAST(? AS TIMESTAMP WITH TIME ZONE) + recurrence
201                 #         WHERE id = ? AND recurrence > '0 seconds'::INTERVAL;
202                 #SQL
203                 $dbh->do(<<'            SQL',{}, $r->{stage3}->{id});
204                         UPDATE  reporter.stage3
205                           SET   runtime = runtime + recurrence
206                           WHERE id = ? AND recurrence > '0 seconds'::INTERVAL;
207                 SQL
208                 $dbh->do(<<'            SQL',{}, $r->{stage3}->{id});
209                         UPDATE  reporter.stage3
210                           SET   rerun = FALSE
211                           WHERE id = ? AND rerun = TRUE;
212                 SQL
213                 $dbh->do(<<'            SQL',{}, $r->{id});
214                         UPDATE  reporter.output
215                           SET   state = 'complete',
216                                 complete_time = 'now'
217                           WHERE id = ?;
218                 SQL
219                 $dbh->commit;
220
221
222         } otherwise {
223                 my $e = shift;
224                 $dbh->rollback;
225                 $dbh->do(<<'            SQL',{}, $e, $r->{id});
226                         UPDATE  reporter.output
227                           SET   state = 'error',
228                                 error_time = 'now',
229                                 error = ?,
230                                 run_pid = NULL
231                           WHERE id = ?;
232                 SQL
233         };
234
235         $dbh->disconnect;
236
237         exit; # leave the child
238 }
239
240 if ($daemon) {
241         sleep 1;
242         POSIX::waitpid( -1, POSIX::WNOHANG );
243         sleep 60;
244         goto DAEMON;
245 }
246
247 #-------------------------------------------------------------------
248
249 sub pivot_data {
250         my $r = shift;
251         my $p = JSON->JSON2perl( $r->{stage3}->{params} );
252         my $settings = $r->{sql};
253         my $data = $r->{data};
254
255         return unless (defined($settings->{pivot}));
256
257         my @groups = (map { ($_ - 1) } @{ $settings->{groupby} });
258         my @values = (0 .. (scalar(@{$settings->{columns}}) - 1));
259         splice(@values,$_,1) for (reverse @groups);
260
261         # remove pivot from group-by
262         my $count = 0;
263         my $pivot_groupby;
264         while ($count < scalar(@{$settings->{groupby}})) {
265                 if (defined $pivot_groupby) {
266                         $settings->{groupby}->[$count] -= 1;
267                         if ($settings->{groupby}->[$count] >= $values[0] + 1) {
268                                 $settings->{groupby}->[$count] -= 1;
269                         }
270                 } elsif ($settings->{groupby}->[$count] == $settings->{pivot} + 1) {
271                         $pivot_groupby = $count;
272                 }
273                 $count++;
274         }
275
276
277         # grab positions of non-group-bys
278         @values = (0 .. (scalar(@{$settings->{columns}}) - 1));
279         splice(@values,$_,1) for (reverse @groups);
280         
281         # we're only doing one "value" for now, so grab that and remove from headings
282         my ($val_col) = @values;
283
284         my @remove_me = sort
285                 { $b <=> $a }
286                 ($val_col, $settings->{groupby}->[$pivot_groupby] - 1);
287
288         my %p_header;
289         for my $row (@$data) {
290                 $p_header{ $$row[$settings->{pivot}] } = [] unless exists($p_header{ $$row[$settings->{pivot}] });
291                 
292                 push @{ $p_header{ $$row[$settings->{pivot}] } }, $$row[$val_col];
293                 
294                 splice(@$row,$_,1) for (@remove_me);
295         }
296
297         push @{ $settings->{columns} }, sort keys %p_header;
298
299         # remove from headings;
300         splice(@{$settings->{columns}},$_,1) for (@remove_me);
301
302         # remove pivot from groupby
303         splice(@{$settings->{groupby}}, $pivot_groupby, 1);
304         @groups = (map { ($_ - 1) } @{ $settings->{groupby} });
305
306         $count = scalar(keys %p_header);
307         my %seenit;
308         my @new_data;
309         {       no warnings;
310                 for my $row (@$data) {
311
312                         my $fingerprint = join('',@$row[@groups]);
313                         next if $seenit{$fingerprint};
314
315                         $seenit{$fingerprint}++;
316
317                         for my $h ( sort keys %p_header ) {
318                                 push @$row, shift(@{ $p_header{$h} });
319                         }
320
321                         push @new_data, [@$row];
322                 }
323         }
324
325         #replace old data with new
326         $r->{data} = \@new_data;
327
328 }
329
330 sub build_csv {
331         my $file = shift;
332         my $r = shift;
333
334         my $csv = Text::CSV_XS->new({ always_quote => 1, eol => "\015\012" });
335
336         return unless ($csv);
337         
338         my $f = new FileHandle (">$file");
339
340         $csv->print($f, $r->{sql}->{columns});
341         $csv->print($f, $_) for (@{$r->{data}});
342
343         $f->close;
344 }
345 sub build_excel {
346         my $file = shift;
347         my $r = shift;
348         my $p = JSON->JSON2perl( $r->{stage3}->{params} );
349
350         my $xls = Spreadsheet::WriteExcel->new($file);
351
352         my $sheetname = substr($p->{reportname},1,31);
353         $sheetname =~ s/\W/_/gos;
354         
355         my $sheet = $xls->add_worksheet($sheetname);
356
357         $sheet->write_row('A1', $r->{sql}->{columns});
358
359         $sheet->write_col('A2', $r->{data});
360
361         $xls->close;
362 }
363
364 sub build_html {
365         my $file = shift;
366         my $r = shift;
367         my $p = JSON->JSON2perl( $r->{stage3}->{params} );
368
369         my $index = new FileHandle (">$file");
370         my $raw = new FileHandle (">$file.raw.html");
371         
372         # index header
373         print $index <<"        HEADER";
374 <html>
375         <head>
376                 <title>$$p{reportname}</title>
377                 <style>
378                         table { border-collapse: collapse; }
379                         th { background-color: lightgray; }
380                         td,th { border: solid black 1px; }
381                         * { font-family: sans-serif; font-size: 10px; }
382                 </style>
383         </head>
384         <body>
385                 <h2><u>$$p{reportname}</u></h2>
386         HEADER
387
388         
389         # add a link to the raw output html
390         print $index "<a href='report-data.html.raw.html'>Raw output data</a><br/><br/><br/><br/>";
391
392         # create the raw output html file
393         print $raw "<html><head><title>$$p{reportname}</title>";
394
395         print $raw <<'  CSS';
396                 <style>
397                         table { border-collapse: collapse; }
398                         th { background-color: lightgray; }
399                         td,th { border: solid black 1px; }
400                         * { font-family: sans-serif; font-size: 10px; }
401                 </style>
402         CSS
403
404         print $raw "</head><body><table>";
405
406         {       no warnings;
407                 print $raw "<tr><th>".join('</th><th>',@{$r->{sql}->{columns}}).'</th></tr>';
408                 print $raw "<tr><td>".join('</td><td>',@$_                    ).'</td></tr>' for (@{$r->{data}});
409         }
410
411         print $raw '</table></body></html>';
412         
413         $raw->close;
414
415         # get the graph types
416         my @graphs;
417         if (ref $$p{html_graph_type}) {
418                 @graphs = @{ $$p{html_graph_type} };
419         } else {
420                 @graphs = ( $$p{html_graph_type} );
421         }
422
423         # Time for a pie chart
424         if (grep {$_ eq 'pie'} @graphs) {
425                 my $pics = draw_pie($r, $p, $file);
426                 for my $pic (@$pics) {
427                         print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/><br/><br/><br/><br/>";
428                 }
429         }
430
431         print $index '<br/><br/><br/><br/>';
432         # Time for a bar chart
433         if (grep {$_ eq 'bar'} @graphs) {
434                 my $pics = draw_bars($r, $p, $file);
435                 for my $pic (@$pics) {
436                         print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/><br/><br/><br/><br/>";
437                 }
438         }
439
440         print $index '<br/><br/><br/><br/>';
441         # Time for a bar chart
442         if (grep {$_ eq 'line'} @graphs) {
443                 my $pics = draw_lines($r, $p, $file);
444                 for my $pic (@$pics) {
445                         print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/><br/><br/><br/><br/>";
446                 }
447         }
448
449
450         # and that's it!
451         print $index '</body></html>';
452         
453         $index->close;
454 }
455
456 sub draw_pie {
457         my $r = shift;
458         my $p = shift;
459         my $file = shift;
460         my $data = $r->{data};
461         my $settings = $r->{sql};
462
463         my @groups = (map { ($_ - 1) } @{ $settings->{groupby} });
464         
465         my @values = (0 .. (scalar(@{$settings->{columns}}) - 1));
466         delete @values[@groups];
467
468         my $logo = $doc->findvalue('/reporter/setup/files/chart_logo');
469         
470         my @pics;
471         for my $vcol (@values) {
472                 next unless (defined $vcol);
473
474                 my @pic_data = ([],[]);
475                 for my $row (@$data) {
476                         next if (!defined($$row[$vcol]) || $$row[$vcol] == 0);
477                         my $val = $$row[$vcol];
478                         push @{$pic_data[0]}, join(" -- ", @$row[@groups])." ($val)";
479                         push @{$pic_data[1]}, $val;
480                 }
481
482                 next unless (@{$pic_data[0]});
483
484                 my $size = 300;
485                 my $split = int(scalar(@{$pic_data[0]}) / $size);
486                 my $last = scalar(@{$pic_data[0]}) % $size;
487
488                 for my $sub_graph (0 .. $split) {
489                         
490                         if ($sub_graph == $split) {
491                                 $size = $last;
492                         }
493
494                         my @sub_data;
495                         for my $set (@pic_data) {
496                                 push @sub_data, [ splice(@$set,0,$size) ];
497                         }
498
499                         my $pic = new GD::Graph::pie;
500
501                         $pic->set(
502                                 label                   => $settings->{columns}->[$vcol],
503                                 start_angle             => 180,
504                                 legend_placement        => 'R',
505                                 logo                    => $logo,
506                                 logo_position           => 'TL',
507                                 logo_resize             => 0.5,
508                                 show_values             => 1,
509                         );
510
511                         my $format = $pic->export_format;
512
513                         open(IMG, ">$file.pie.$vcol.$sub_graph.$format");
514                         binmode IMG;
515
516                         my $forgetit = 0;
517                         try {
518                                 $pic->plot(\@sub_data) or die $pic->error;
519                                 print IMG $pic->gd->$format;
520                         } otherwise {
521                                 my $e = shift;
522                                 warn "Couldn't draw $file.pie.$vcol.$sub_graph.$format : $e";
523                                 $forgetit = 1;
524                         };
525
526                         close IMG;
527
528
529                         push @pics,
530                                 { file => "pie.$vcol.$sub_graph.$format",
531                                   name => $settings->{columns}->[$vcol].' (Pie)',
532                                 } unless ($forgetit);
533
534                         last if ($sub_graph == $split);
535                 }
536
537         }
538         
539         return \@pics;
540 }
541
542 sub draw_bars {
543         my $r = shift;
544         my $p = shift;
545         my $file = shift;
546         my $data = $r->{data};
547         my $settings = $r->{sql};
548
549         my $logo = $doc->findvalue('/reporter/setup/files/chart_logo');
550
551         my @groups = (map { ($_ - 1) } @{ $settings->{groupby} });
552
553         
554         my @values = (0 .. (scalar(@{$settings->{columns}}) - 1));
555         splice(@values,$_,1) for (reverse @groups);
556
557         my @pic_data;
558         {       no warnings;
559                 for my $row (@$data) {
560                         push @{$pic_data[0]}, join(' -- ', @$row[@groups]);
561                 }
562         }
563
564         my @leg;
565         my $set = 1;
566
567         my %trim_candidates;
568
569         my $max_y = 0;
570         for my $vcol (@values) {
571                 next unless (defined $vcol);
572
573
574                 my $pos = 0;
575                 for my $row (@$data) {
576                         my $val = $$row[$vcol] ? $$row[$vcol] : 0;
577                         push @{$pic_data[$set]}, $val;
578                         $max_y = $val if ($val > $max_y);
579                         $trim_candidates{$pos}++ if ($val == 0);
580                         $pos++;
581                 }
582
583                 $set++;
584         }
585         my $set_count = scalar(@pic_data) - 1;
586         my @trim_cols = grep { $trim_candidates{$_} == $set_count } keys %trim_candidates;
587
588         my @new_data;
589         my @use_me;
590         my @no_use;
591         my $set_index = 0;
592         for my $dataset (@pic_data) {
593                 splice(@$dataset,$_,1) for (sort { $b <=> $a } @trim_cols);
594
595                 if (grep { $_ } @$dataset) {
596                         push @new_data, $dataset;
597                         push @use_me, $set_index;
598                 } else {
599                         push @no_use, $set_index;
600                 }
601                 $set_index++;
602                 
603         }
604
605         return [] unless ($new_data[0] && @{$new_data[0]});
606
607         for my $col (@use_me) {
608                 push @leg, $settings->{columns}->[$col + @groups - 1] if (map { 1 } grep { $col == $_ } @values);
609         }
610
611         my $w = 100 + 10 * scalar(@{$new_data[0]});
612         $w = 400 if ($w < 400);
613
614         my $h = 10 * (scalar(@new_data) / 2);
615
616         $h = 0 if ($h < 0);
617
618         my $pic = new GD::Graph::bars3d ($w + 250, $h + 500);
619
620         $pic->set(
621                 title                   => $p->{reportname},
622                 x_labels_vertical       => 1,
623                 shading                 => 1,
624                 bar_depth               => 5,
625                 bar_spacing             => 2,
626                 y_max_value             => $max_y,
627                 legend_placement        => 'TR',
628                 boxclr                  => 'lgray',
629                 logo                    => $logo,
630                 logo_position           => 'R',
631                 logo_resize             => 0.5,
632                 show_values             => 1,
633                 overwrite               => 1,
634         );
635         $pic->set_legend(@leg);
636
637         my $format = $pic->export_format;
638
639         open(IMG, ">$file.bar.$format");
640         binmode IMG;
641
642         try {
643                 $pic->plot(\@new_data) or die $pic->error;
644                 print IMG $pic->gd->$format;
645         } otherwise {
646                 my $e = shift;
647                 warn "Couldn't draw $file.bar.$format : $e";
648         };
649
650         close IMG;
651
652         return [{ file => "bar.$format",
653                   name => $p->{reportname}.' (Bar)',
654                 }];
655
656 }
657
658 sub draw_lines {
659         my $r = shift;
660         my $p = shift;
661         my $file = shift;
662         my $data = $r->{data};
663         my $settings = $r->{sql};
664
665         my $logo = $doc->findvalue('/reporter/setup/files/chart_logo');
666
667         my @groups = (map { ($_ - 1) } @{ $settings->{groupby} });
668
669         
670         my @values = (0 .. (scalar(@{$settings->{columns}}) - 1));
671         splice(@values,$_,1) for (reverse @groups);
672
673         my @pic_data;
674         {       no warnings;
675                 for my $row (@$data) {
676                         push @{$pic_data[0]}, join(' -- ', @$row[@groups]);
677                 }
678         }
679
680         my @leg;
681         my $set = 1;
682
683         my $max_y = 0;
684         for my $vcol (@values) {
685                 next unless (defined $vcol);
686
687
688                 for my $row (@$data) {
689                         my $val = $$row[$vcol] ? $$row[$vcol] : 0;
690                         push @{$pic_data[$set]}, $val;
691                         $max_y = $val if ($val > $max_y);
692                 }
693
694                 $set++;
695         }
696         my $set_count = scalar(@pic_data) - 1;
697
698         my @new_data;
699         my @use_me;
700         my @no_use;
701         my $set_index = 0;
702         for my $dataset (@pic_data) {
703
704                 if (grep { $_ } @$dataset) {
705                         push @new_data, $dataset;
706                         push @use_me, $set_index;
707                 } else {
708                         push @no_use, $set_index;
709                 }
710                 $set_index++;
711                 
712         }
713
714         for my $col (@use_me) {
715                 push @leg, $settings->{columns}->[$col + @groups - 1] if (map { 1 } grep { $col == $_ } @values);
716         }
717
718         my $w = 100 + 10 * scalar(@{$new_data[0]});
719         $w = 400 if ($w < 400);
720
721         my $h = 10 * (scalar(@new_data) / 2);
722
723         $h = 0 if ($h < 0);
724
725         my $pic = new GD::Graph::lines3d ($w + 250, $h + 500);
726
727         $pic->set(
728                 title                   => $p->{reportname},
729                 x_labels_vertical       => 1,
730                 shading                 => 1,
731                 line_depth              => 5,
732                 y_max_value             => $max_y,
733                 legend_placement        => 'TR',
734                 boxclr                  => 'lgray',
735                 logo                    => $logo,
736                 logo_position           => 'R',
737                 logo_resize             => 0.5,
738                 show_values             => 1,
739                 overwrite               => 1,
740         );
741         $pic->set_legend(@leg);
742
743         my $format = $pic->export_format;
744
745         open(IMG, ">$file.line.$format");
746         binmode IMG;
747
748         try {
749                 $pic->plot(\@new_data) or die $pic->error;
750                 print IMG $pic->gd->$format;
751         } otherwise {
752                 my $e = shift;
753                 warn "Couldn't draw $file.line.$format : $e";
754         };
755
756         close IMG;
757
758         return [{ file => "line.$format",
759                   name => $p->{reportname}.' (Bar)',
760                 }];
761
762 }
763
764 sub table_by_id {
765         my $id = shift;
766         my ($node) = $doc->findnodes("//*[\@id='$id']");
767         if ($node && $node->findvalue('@table')) {
768                 ($node) = $doc->findnodes("//*[\@id='".$node->getAttribute('table')."']");
769         }
770         return $node;
771 }
772
773 sub generate_query {
774         my $r = shift;
775
776         my $p = JSON->JSON2perl( $r->{stage3}->{params} );
777
778         my @group_by = ();
779         my @aggs = ();
780         my $core = $r->{stage3}->{stage2}->{stage1};
781         my @dims = ();
782
783         for my $t (keys %{$$p{filter}}) {
784                 if ($t ne $core) {
785                         push @dims, $t;
786                 }
787         }
788
789         for my $t (keys %{$$p{output}}) {
790                 if ($t ne $core && !(grep { $t eq $_ } @dims) ) {
791                         push @dims, $t;
792                 }
793         }
794
795         my @dim_select = ();
796         my @dim_from = ();
797         for my $d (@dims) {
798                 my $t = table_by_id($d);
799                 my $t_name = $t->findvalue('tablename');
800                 push @dim_from, "$t_name AS \"$d\""
801                         unless ( grep {$_ eq "$t_name AS \"$d\""} @dim_from );
802
803                 my $k = $doc->findvalue("//*[\@id='$d']/\@key");
804                 push @dim_select, "\"$d\".\"$k\" AS \"${d}_${k}\""
805                         unless ( grep {$_ eq "\"$d\".\"$k\" AS \"${d}_${k}\""} @dim_select );
806
807                 for my $c ( keys %{$$p{output}{$d}} ) {
808                         push @dim_select, "\"$d\".\"$c\" AS \"${d}_${c}\""
809                                 unless ( grep {$_ eq "\"$d\".\"$c\" AS \"${d}_${c}\""} @dim_select );
810                 }
811
812                 for my $c ( keys %{$$p{filter}{$d}} ) {
813                         next if (exists $$p{output}{$d}{$c});
814                         push @dim_select, "\"$d\".\"$c\" AS \"${d}_${c}\""
815                                 unless ( grep {$_ eq "\"$d\".\"$c\" AS \"${d}_${c}\""} @dim_select );
816                 }
817         }
818
819         my $d_select =
820                 '(SELECT ' . join(',', @dim_select) .
821                 '  FROM ' . join(',', @dim_from) . ') AS dims';
822         
823         my @opord = ();
824         if (ref $$p{output_order}) {
825                 @opord = @{ $$p{output_order} };
826         } else {
827                 @opord = ( $$p{output_order} );
828         }
829         my @output_order = map { { (split ':')[1] => (split ':')[2] } } @opord;
830         my @p_col = split(':',$p->{pivot_col}) if $p->{pivot_col};
831         my $pivot = undef;
832
833         my $col = 1;
834         my @groupby = ();
835         my @output = ();
836         my @dim_col_names = ();
837         my @columns = ();
838         my @join = ();
839         my @join_base = ();
840         for my $pair (@output_order) {
841                 my ($t_name) = keys %$pair;
842                 my $t = $t_name;
843
844                 $t_name = "dims" if ($t ne $core);
845
846                 my $t_node = table_by_id($t);
847
848                 for my $c ( values %$pair ) {
849                         my $label = $t_node->findvalue("fields/field[\@name='$c']/label");
850
851                         my $full_col = $c;
852                         $full_col = "${t}_${c}" if ($t ne $t_name);
853                         $full_col = "\"$t_name\".\"$full_col\"";
854
855                         if (my $xform_type = $$p{xform}{type}{$t}{$c}) {
856                                 my $xform = $$OpenILS::WWW::Reporter::dtype_xforms{$xform_type};
857                                 if ($xform->{group}) {
858                                         push @groupby, $col;
859                                 }
860                                 $label = "$$xform{label} -- $label";
861
862                                 my $tmp = $xform->{'select'};
863                                 $tmp =~ s/\?COLNAME\?/$full_col/gs;
864                                 $tmp =~ s/\?PARAM\?/$$p{xform}{param}{$t}{$c}/gs;
865                                 $full_col = $tmp;
866                         } else {
867                                 push @groupby, $col;
868                         }
869
870                         push @output, "$full_col AS \"$label\"";
871                         push @columns, $label;
872                         $pivot = scalar(@columns) - 1 if (@p_col && $t eq $p_col[1] && $c eq $p_col[2]);
873                         $col++;
874                 }
875
876                 if ($t ne $t_name && (!@join_base || !grep{$t eq $_}@join_base)) {
877                         my $k = $doc->findvalue("//*[\@id='$t']/\@key");
878                         my $f = $doc->findvalue("//*[\@id='$t']/\@field");
879                         push @join, "dims.\"${t}_${k}\" = \"$core\".\"$f\"";
880                         push @join_base, $t;
881                 }
882         }
883
884         my @where = ();
885         my @bind = ();
886         for my $t ( keys %{$$p{filter}} ) {
887                 my $t_name = $t;
888                 $t_name = "dims" if ($t ne $core);
889
890                 my $t_node = table_by_id($t);
891
892                 for my $c ( keys %{$$p{filter}{$t}} ) {
893                         my $label = $t_node->findvalue("fields/field[\@name='$c']/label");
894
895                         my $full_col = $c;
896                         $full_col = "${t}_${c}" if ($t ne $t_name);
897                         $full_col = "\"$t_name\".\"$full_col\"";
898
899                         my ($fam) = keys %{ $$p{filter}{$t}{$c} };
900                         my ($w) = keys %{ $$p{filter}{$t}{$c}{$fam} };
901                         my $val = $$p{filter}{$t}{$c}{$fam}{$w};
902
903                         my $filter_code_xpath = "/reporter/widgets/widget-family[\@name='$fam']/widget[\@name='$w']/filter-code[\@type='perl']";
904                         if (my $widget_code = $doc->findvalue($filter_code_xpath)) { # widget supplys it's own filter code
905                                 my ($where_clause, $bind_list) = ('',[]);
906
907                                 eval $widget_code;
908
909                                 die "$@\n\n$widget_code" if ($@);
910
911                                 push @where, $where_clause;
912                                 push @bind, @$bind_list;
913
914                         } elsif (ref $val) {
915                                 push @where, "$full_col IN (".join(",",map {'?'}@$val).")";
916                                 push @bind, @$val;
917                         } else {
918                                 push @where, "$full_col = ?";
919                                 push @bind, $val;
920                         }
921                 }
922
923                 if ($t ne $t_name && (!@join_base || !grep{$t eq $_}@join_base)) {
924                         my $k = $doc->findvalue("//*[\@id='$t']/\@key");
925                         my $f = $doc->findvalue("//*[\@id='$t']/\@field");
926                         push @join, "dims.\"${t}_${k}\" = \"$core\".\"$f\"";
927                         push @join_base, $t;
928                 }
929         }
930
931         my $t = table_by_id($core)->findvalue('tablename');
932
933         my $from = " FROM $t AS \"$core\" ";
934         $from .= "RIGHT JOIN $d_select ON (". join(' AND ', @join).")" if ( @join );
935
936         my $select =
937                 "SELECT ".join(',', @output). $from;
938
939         $select .= ' WHERE '.join(' AND ', @where) if (@where);
940         $select .= ' GROUP BY '.join(',',@groupby) if (@groupby);
941
942         $r->{sql}->{'pivot'}    = $pivot;
943         $r->{sql}->{'select'}   = $select;
944         $r->{sql}->{'bind'}     = \@bind;
945         $r->{sql}->{columns}    = \@columns;
946         $r->{sql}->{groupby}    = \@groupby;
947         
948 }
949
950
951
952
953
954