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