bug hunting and a (small) new set of widget code
[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         my $f = new FileHandle (">$file");
336
337         $csv->print($f, $r->{sql}->{columns});
338         $csv->print($f, $_) for (@{$r->{data}});
339
340         $f->close;
341 }
342 sub build_excel {
343         my $file = shift;
344         my $r = shift;
345         my $p = JSON->JSON2perl( $r->{stage3}->{params} );
346
347         my $xls = Spreadsheet::WriteExcel->new($file);
348
349         my $sheetname = substr($p->{reportname},1,31);
350         $sheetname =~ s/\W/_/gos;
351         
352         my $sheet = $xls->add_worksheet($sheetname);
353
354         $sheet->write_row('A1', $r->{sql}->{columns});
355
356         $sheet->write_col('A2', $r->{data});
357
358         $xls->close;
359 }
360
361 sub build_html {
362         my $file = shift;
363         my $r = shift;
364         my $p = JSON->JSON2perl( $r->{stage3}->{params} );
365
366         my $index = new FileHandle (">$file");
367         my $raw = new FileHandle (">$file.raw.html");
368         
369         # index header
370         print $index <<"        HEADER";
371 <html>
372         <head>
373                 <title>$$p{reportname}</title>
374                 <style>
375                         table { border-collapse: collapse; }
376                         th { background-color: lightgray; }
377                         td,th { border: solid black 1px; }
378                         * { font-family: sans-serif; font-size: 10px; }
379                 </style>
380         </head>
381         <body>
382                 <h2><u>$$p{reportname}</u></h2>
383         HEADER
384
385         
386         # add a link to the raw output html
387         print $index "<a href='report-data.html.raw.html'>Raw output data</a><br/><br/><br/><br/>";
388
389         # create the raw output html file
390         print $raw "<html><head><title>$$p{reportname}</title>";
391
392         print $raw <<'  CSS';
393                 <style>
394                         table { border-collapse: collapse; }
395                         th { background-color: lightgray; }
396                         td,th { border: solid black 1px; }
397                         * { font-family: sans-serif; font-size: 10px; }
398                 </style>
399         CSS
400
401         print $raw "</head><body><table>";
402
403         {       no warnings;
404                 print $raw "<tr><th>".join('</th><th>',@{$r->{sql}->{columns}}).'</th></tr>';
405                 print $raw "<tr><td>".join('</td><td>',@$_                    ).'</td></tr>' for (@{$r->{data}});
406         }
407
408         print $raw '</table></body></html>';
409         
410         $raw->close;
411
412         # get the graph types
413         my @graphs;
414         if (ref $$p{html_graph_type}) {
415                 @graphs = @{ $$p{html_graph_type} };
416         } else {
417                 @graphs = ( $$p{html_graph_type} );
418         }
419
420         # Time for a pie chart
421         if (grep {$_ eq 'pie'} @graphs) {
422                 my $pics = draw_pie($r, $p, $file);
423                 for my $pic (@$pics) {
424                         print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/><br/><br/><br/><br/>";
425                 }
426         }
427
428         print $index '<br/><br/><br/><br/>';
429         # Time for a bar chart
430         if (grep {$_ eq 'bar'} @graphs) {
431                 my $pics = draw_bars($r, $p, $file);
432                 for my $pic (@$pics) {
433                         print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/><br/><br/><br/><br/>";
434                 }
435         }
436
437         print $index '<br/><br/><br/><br/>';
438         # Time for a bar chart
439         if (grep {$_ eq 'line'} @graphs) {
440                 my $pics = draw_lines($r, $p, $file);
441                 for my $pic (@$pics) {
442                         print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/><br/><br/><br/><br/>";
443                 }
444         }
445
446
447         # and that's it!
448         print $index '</body></html>';
449         
450         $index->close;
451 }
452
453 sub draw_pie {
454         my $r = shift;
455         my $p = shift;
456         my $file = shift;
457         my $data = $r->{data};
458         my $settings = $r->{sql};
459
460         my @groups = (map { ($_ - 1) } @{ $settings->{groupby} });
461         
462         my @values = (0 .. (scalar(@{$settings->{columns}}) - 1));
463         delete @values[@groups];
464
465         my $logo = $doc->findvalue('/reporter/setup/files/chart_logo');
466         
467         my @pics;
468         for my $vcol (@values) {
469                 next unless (defined $vcol);
470
471                 my @pic_data = ([],[]);
472                 for my $row (@$data) {
473                         next if (!defined($$row[$vcol]) || $$row[$vcol] == 0);
474                         my $val = $$row[$vcol];
475                         push @{$pic_data[0]}, join(" -- ", @$row[@groups])." ($val)";
476                         push @{$pic_data[1]}, $val;
477                 }
478
479                 next unless (@{$pic_data[0]});
480
481                 my $size = 300;
482                 my $split = int(scalar(@{$pic_data[0]}) / $size);
483                 my $last = scalar(@{$pic_data[0]}) % $size;
484
485                 for my $sub_graph (0 .. $split) {
486                         
487                         if ($sub_graph == $split) {
488                                 $size = $last;
489                         }
490
491                         my @sub_data;
492                         for my $set (@pic_data) {
493                                 push @sub_data, [ splice(@$set,0,$size) ];
494                         }
495
496                         my $pic = new GD::Graph::pie;
497
498                         $pic->set(
499                                 label                   => $settings->{columns}->[$vcol],
500                                 start_angle             => 180,
501                                 legend_placement        => 'R',
502                                 logo                    => $logo,
503                                 logo_position           => 'TL',
504                                 logo_resize             => 0.5,
505                                 show_values             => 1,
506                         );
507
508                         my $format = $pic->export_format;
509
510                         open(IMG, ">$file.pie.$vcol.$sub_graph.$format");
511                         binmode IMG;
512
513                         my $forgetit = 0;
514                         try {
515                                 $pic->plot(\@sub_data) or die $pic->error;
516                                 print IMG $pic->gd->$format;
517                         } otherwise {
518                                 my $e = shift;
519                                 warn "Couldn't draw $file.pie.$vcol.$sub_graph.$format : $e";
520                                 $forgetit = 1;
521                         };
522
523                         close IMG;
524
525
526                         push @pics,
527                                 { file => "pie.$vcol.$sub_graph.$format",
528                                   name => $settings->{columns}->[$vcol].' (Pie)',
529                                 } unless ($forgetit);
530
531                         last if ($sub_graph == $split);
532                 }
533
534         }
535         
536         return \@pics;
537 }
538
539 sub draw_bars {
540         my $r = shift;
541         my $p = shift;
542         my $file = shift;
543         my $data = $r->{data};
544         my $settings = $r->{sql};
545
546         my $logo = $doc->findvalue('/reporter/setup/files/chart_logo');
547
548         my @groups = (map { ($_ - 1) } @{ $settings->{groupby} });
549
550         
551         my @values = (0 .. (scalar(@{$settings->{columns}}) - 1));
552         splice(@values,$_,1) for (reverse @groups);
553
554         my @pic_data;
555         {       no warnings;
556                 for my $row (@$data) {
557                         push @{$pic_data[0]}, join(' -- ', @$row[@groups]);
558                 }
559         }
560
561         my @leg;
562         my $set = 1;
563
564         my %trim_candidates;
565
566         my $max_y = 0;
567         for my $vcol (@values) {
568                 next unless (defined $vcol);
569
570
571                 my $pos = 0;
572                 for my $row (@$data) {
573                         my $val = $$row[$vcol] ? $$row[$vcol] : 0;
574                         push @{$pic_data[$set]}, $val;
575                         $max_y = $val if ($val > $max_y);
576                         $trim_candidates{$pos}++ if ($val == 0);
577                         $pos++;
578                 }
579
580                 $set++;
581         }
582         my $set_count = scalar(@pic_data) - 1;
583         my @trim_cols = grep { $trim_candidates{$_} == $set_count } keys %trim_candidates;
584
585         my @new_data;
586         my @use_me;
587         my @no_use;
588         my $set_index = 0;
589         for my $dataset (@pic_data) {
590                 splice(@$dataset,$_,1) for (sort { $b <=> $a } @trim_cols);
591
592                 if (grep { $_ } @$dataset) {
593                         push @new_data, $dataset;
594                         push @use_me, $set_index;
595                 } else {
596                         push @no_use, $set_index;
597                 }
598                 $set_index++;
599                 
600         }
601
602         return [] unless ($new_data[0] && @{$new_data[0]});
603
604         for my $col (@use_me) {
605                 push @leg, $settings->{columns}->[$col + @groups - 1] if (map { 1 } grep { $col == $_ } @values);
606         }
607
608         my $w = 100 + 10 * scalar(@{$new_data[0]});
609         $w = 400 if ($w < 400);
610
611         my $h = 10 * (scalar(@new_data) / 2);
612
613         $h = 0 if ($h < 0);
614
615         my $pic = new GD::Graph::bars3d ($w + 250, $h + 500);
616
617         $pic->set(
618                 title                   => $p->{reportname},
619                 x_labels_vertical       => 1,
620                 shading                 => 1,
621                 bar_depth               => 5,
622                 bar_spacing             => 2,
623                 y_max_value             => $max_y,
624                 legend_placement        => 'TR',
625                 boxclr                  => 'lgray',
626                 logo                    => $logo,
627                 logo_position           => 'R',
628                 logo_resize             => 0.5,
629                 show_values             => 1,
630                 overwrite               => 1,
631         );
632         $pic->set_legend(@leg);
633
634         my $format = $pic->export_format;
635
636         open(IMG, ">$file.bar.$format");
637         binmode IMG;
638
639         try {
640                 $pic->plot(\@new_data) or die $pic->error;
641                 print IMG $pic->gd->$format;
642         } otherwise {
643                 my $e = shift;
644                 warn "Couldn't draw $file.bar.$format : $e";
645         };
646
647         close IMG;
648
649         return [{ file => "bar.$format",
650                   name => $p->{reportname}.' (Bar)',
651                 }];
652
653 }
654
655 sub draw_lines {
656         my $r = shift;
657         my $p = shift;
658         my $file = shift;
659         my $data = $r->{data};
660         my $settings = $r->{sql};
661
662         my $logo = $doc->findvalue('/reporter/setup/files/chart_logo');
663
664         my @groups = (map { ($_ - 1) } @{ $settings->{groupby} });
665
666         
667         my @values = (0 .. (scalar(@{$settings->{columns}}) - 1));
668         splice(@values,$_,1) for (reverse @groups);
669
670         my @pic_data;
671         {       no warnings;
672                 for my $row (@$data) {
673                         push @{$pic_data[0]}, join(' -- ', @$row[@groups]);
674                 }
675         }
676
677         my @leg;
678         my $set = 1;
679
680         my $max_y = 0;
681         for my $vcol (@values) {
682                 next unless (defined $vcol);
683
684
685                 for my $row (@$data) {
686                         my $val = $$row[$vcol] ? $$row[$vcol] : 0;
687                         push @{$pic_data[$set]}, $val;
688                         $max_y = $val if ($val > $max_y);
689                 }
690
691                 $set++;
692         }
693         my $set_count = scalar(@pic_data) - 1;
694
695         my @new_data;
696         my @use_me;
697         my @no_use;
698         my $set_index = 0;
699         for my $dataset (@pic_data) {
700
701                 if (grep { $_ } @$dataset) {
702                         push @new_data, $dataset;
703                         push @use_me, $set_index;
704                 } else {
705                         push @no_use, $set_index;
706                 }
707                 $set_index++;
708                 
709         }
710
711         for my $col (@use_me) {
712                 push @leg, $settings->{columns}->[$col + @groups - 1] if (map { 1 } grep { $col == $_ } @values);
713         }
714
715         my $w = 100 + 10 * scalar(@{$new_data[0]});
716         $w = 400 if ($w < 400);
717
718         my $h = 10 * (scalar(@new_data) / 2);
719
720         $h = 0 if ($h < 0);
721
722         my $pic = new GD::Graph::lines3d ($w + 250, $h + 500);
723
724         $pic->set(
725                 title                   => $p->{reportname},
726                 x_labels_vertical       => 1,
727                 shading                 => 1,
728                 line_depth              => 5,
729                 y_max_value             => $max_y,
730                 legend_placement        => 'TR',
731                 boxclr                  => 'lgray',
732                 logo                    => $logo,
733                 logo_position           => 'R',
734                 logo_resize             => 0.5,
735                 show_values             => 1,
736                 overwrite               => 1,
737         );
738         $pic->set_legend(@leg);
739
740         my $format = $pic->export_format;
741
742         open(IMG, ">$file.line.$format");
743         binmode IMG;
744
745         try {
746                 $pic->plot(\@new_data) or die $pic->error;
747                 print IMG $pic->gd->$format;
748         } otherwise {
749                 my $e = shift;
750                 warn "Couldn't draw $file.line.$format : $e";
751         };
752
753         close IMG;
754
755         return [{ file => "line.$format",
756                   name => $p->{reportname}.' (Bar)',
757                 }];
758
759 }
760
761 sub table_by_id {
762         my $id = shift;
763         my ($node) = $doc->findnodes("//*[\@id='$id']");
764         if ($node && $node->findvalue('@table')) {
765                 ($node) = $doc->findnodes("//*[\@id='".$node->getAttribute('table')."']");
766         }
767         return $node;
768 }
769
770 sub generate_query {
771         my $r = shift;
772
773         my $p = JSON->JSON2perl( $r->{stage3}->{params} );
774
775         my @group_by = ();
776         my @aggs = ();
777         my $core = $r->{stage3}->{stage2}->{stage1};
778         my @dims = ();
779
780         for my $t (keys %{$$p{filter}}) {
781                 if ($t ne $core) {
782                         push @dims, $t;
783                 }
784         }
785
786         for my $t (keys %{$$p{output}}) {
787                 if ($t ne $core && !(grep { $t eq $_ } @dims) ) {
788                         push @dims, $t;
789                 }
790         }
791
792         my @dim_select = ();
793         my @dim_from = ();
794         for my $d (@dims) {
795                 my $t = table_by_id($d);
796                 my $t_name = $t->findvalue('tablename');
797                 push @dim_from, "$t_name AS \"$d\""
798                         unless ( grep {$_ eq "$t_name AS \"$d\""} @dim_from );
799
800                 my $k = $doc->findvalue("//*[\@id='$d']/\@key");
801                 push @dim_select, "\"$d\".\"$k\" AS \"${d}_${k}\""
802                         unless ( grep {$_ eq "\"$d\".\"$k\" AS \"${d}_${k}\""} @dim_select );
803
804                 for my $c ( keys %{$$p{output}{$d}} ) {
805                         push @dim_select, "\"$d\".\"$c\" AS \"${d}_${c}\""
806                                 unless ( grep {$_ eq "\"$d\".\"$c\" AS \"${d}_${c}\""} @dim_select );
807                 }
808
809                 for my $c ( keys %{$$p{filter}{$d}} ) {
810                         next if (exists $$p{output}{$d}{$c});
811                         push @dim_select, "\"$d\".\"$c\" AS \"${d}_${c}\""
812                                 unless ( grep {$_ eq "\"$d\".\"$c\" AS \"${d}_${c}\""} @dim_select );
813                 }
814         }
815
816         my $d_select =
817                 '(SELECT ' . join(',', @dim_select) .
818                 '  FROM ' . join(',', @dim_from) . ') AS dims';
819         
820         my @opord = ();
821         if (ref $$p{output_order}) {
822                 @opord = @{ $$p{output_order} };
823         } else {
824                 @opord = ( $$p{output_order} );
825         }
826         my @output_order = map { { (split ':')[1] => (split ':')[2] } } @opord;
827         my @p_col = split(':',$p->{pivot_col}) if $p->{pivot_col};
828         my $pivot = undef;
829
830         my $col = 1;
831         my @groupby = ();
832         my @output = ();
833         my @dim_col_names = ();
834         my @columns = ();
835         my @join = ();
836         my @join_base = ();
837         for my $pair (@output_order) {
838                 my ($t_name) = keys %$pair;
839                 my $t = $t_name;
840
841                 $t_name = "dims" if ($t ne $core);
842
843                 my $t_node = table_by_id($t);
844
845                 for my $c ( values %$pair ) {
846                         my $label = $t_node->findvalue("fields/field[\@name='$c']/label");
847
848                         my $full_col = $c;
849                         $full_col = "${t}_${c}" if ($t ne $t_name);
850                         $full_col = "\"$t_name\".\"$full_col\"";
851
852                         if (my $xform_type = $$p{xform}{type}{$t}{$c}) {
853                                 my $xform = $$OpenILS::WWW::Reporter::dtype_xforms{$xform_type};
854                                 if ($xform->{group}) {
855                                         push @groupby, $col;
856                                 }
857                                 $label = "$$xform{label} -- $label";
858
859                                 my $tmp = $xform->{'select'};
860                                 $tmp =~ s/\?COLNAME\?/$full_col/gs;
861                                 $tmp =~ s/\?PARAM\?/$$p{xform}{param}{$t}{$c}/gs;
862                                 $full_col = $tmp;
863                         } else {
864                                 push @groupby, $col;
865                         }
866
867                         push @output, "$full_col AS \"$label\"";
868                         push @columns, $label;
869                         $pivot = scalar(@columns) - 1 if (@p_col && $t eq $p_col[1] && $c eq $p_col[2]);
870                         $col++;
871                 }
872
873                 if ($t ne $t_name && (!@join_base || !grep{$t eq $_}@join_base)) {
874                         my $k = $doc->findvalue("//*[\@id='$t']/\@key");
875                         my $f = $doc->findvalue("//*[\@id='$t']/\@field");
876                         push @join, "dims.\"${t}_${k}\" = \"$core\".\"$f\"";
877                         push @join_base, $t;
878                 }
879         }
880
881         my @where = ();
882         my @bind = ();
883         for my $t ( keys %{$$p{filter}} ) {
884                 my $t_name = $t;
885                 $t_name = "dims" if ($t ne $core);
886
887                 my $t_node = table_by_id($t);
888
889                 for my $c ( keys %{$$p{filter}{$t}} ) {
890                         my $label = $t_node->findvalue("fields/field[\@name='$c']/label");
891
892                         my $full_col = $c;
893                         $full_col = "${t}_${c}" if ($t ne $t_name);
894                         $full_col = "\"$t_name\".\"$full_col\"";
895
896                         my ($fam) = keys %{ $$p{filter}{$t}{$c} };
897                         my ($w) = keys %{ $$p{filter}{$t}{$c}{$fam} };
898                         my $val = $$p{filter}{$t}{$c}{$fam}{$w};
899
900                         my $filter_code_xpath = "/reporter/widgets/widget-family[\@name='$fam']/widget[\@name='$w']/filter-code[\@type='perl']";
901                         if (my $widget_code = $doc->findvalue($filter_code_xpath)) { # widget supplys it's own filter code
902                                 my ($where_clause, $bind_list) = ('',[]);
903
904                                 eval $widget_code;
905
906                                 die "$@\n\n$widget_code" if ($@);
907
908                                 push @where, $where_clause;
909                                 push @bind, @$bind_list;
910
911                         } elsif (ref $val) {
912                                 push @where, "$full_col IN (".join(",",map {'?'}@$val).")";
913                                 push @bind, @$val;
914                         } else {
915                                 push @where, "$full_col = ?";
916                                 push @bind, $val;
917                         }
918                 }
919
920                 if ($t ne $t_name && (!@join_base || !grep{$t eq $_}@join_base)) {
921                         my $k = $doc->findvalue("//*[\@id='$t']/\@key");
922                         my $f = $doc->findvalue("//*[\@id='$t']/\@field");
923                         push @join, "dims.\"${t}_${k}\" = \"$core\".\"$f\"";
924                         push @join_base, $t;
925                 }
926         }
927
928         my $t = table_by_id($core)->findvalue('tablename');
929
930         my $from = " FROM $t AS \"$core\" ";
931         $from .= "RIGHT JOIN $d_select ON (". join(' AND ', @join).")" if ( @join );
932
933         my $select =
934                 "SELECT ".join(',', @output). $from;
935
936         $select .= ' WHERE '.join(' AND ', @where) if (@where);
937         $select .= ' GROUP BY '.join(',',@groupby) if (@groupby);
938
939         $r->{sql}->{'pivot'}    = $pivot;
940         $r->{sql}->{'select'}   = $select;
941         $r->{sql}->{'bind'}     = \@bind;
942         $r->{sql}->{columns}    = \@columns;
943         $r->{sql}->{groupby}    = \@groupby;
944         
945 }
946
947
948
949
950
951