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