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