9 use DateTime::Format::ISO8601;
12 use OpenILS::WWW::Reporter::transforms;
14 use Spreadsheet::WriteExcel;
15 use OpenSRF::EX qw/:try/;
16 use OpenSRF::Utils qw/:daemon/;
17 use OpenSRF::Utils::Logger qw/:level/;
20 use GD::Graph::bars3d;
25 my $current_time = DateTime->from_epoch( epoch => time() )->strftime('%FT%T%z');
27 my ($base_xml, $count, $daemon) = ('/openils/conf/reporter.xml', 1);
30 "file=s" => \$base_xml,
32 "concurrency=i" => \$count,
35 my $parser = XML::LibXML->new;
36 $parser->expand_xinclude(1);
38 my $doc = $parser->parse_file($base_xml);
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');
46 my $dsn = "dbi:" . $db_driver . ":dbname=" . $db_name .';host=' . $db_host;
50 daemonize("Clark Kent, waiting for trouble") if ($daemon);
54 $dbh = DBI->connect($dsn,$db_user,$db_pw, {pg_enable_utf8 => 1, RaiseError => 1});
56 # Move new reports into the run queue
57 $dbh->do(<<'SQL', {}, $current_time);
58 INSERT INTO reporter.output ( stage3, state )
62 AND ( ( recurrence = '0 seconds'::INTERVAL
64 id NOT IN ( SELECT stage3 FROM reporter.output )
68 OR ( recurrence > '0 seconds'::INTERVAL
72 WHERE state <> 'complete')
78 # make sure we're not already running $count reports
79 my ($running) = $dbh->selectrow_array(<<SQL);
82 WHERE state = 'running';
85 if ($count <= $running) {
89 POSIX::waitpid( -1, POSIX::WNOHANG );
93 print "Already running maximum ($running) concurrent reports\n";
97 # if we have some open slots then generate the sql
98 my $run = $count - $running;
100 my $sth = $dbh->prepare(<<SQL);
111 while (my $r = $sth->fetchrow_hashref) {
112 my $s3 = $dbh->selectrow_hashref(<<" SQL", {}, $r->{stage3});
113 SELECT * FROM reporter.stage3 WHERE id = ?;
116 my $s2 = $dbh->selectrow_hashref(<<" SQL", {}, $s3->{stage2});
117 SELECT * FROM reporter.stage2 WHERE id = ?;
123 generate_query( $r );
131 # Now we spaun the report runners
133 for my $r ( @reports ) {
134 next if (safe_fork());
136 # This is the child (runner) process;
137 my $p = JSON->JSON2perl( $r->{stage3}->{params} );
138 daemonize("Clark Kent reporting: $p->{reportname}");
140 $dbh = DBI->connect($dsn,$db_user,$db_pw, {pg_enable_utf8 => 1, RaiseError => 1});
143 $dbh->do(<<' SQL',{}, $r->{sql}->{'select'}, $$, $r->{id});
144 UPDATE reporter.output
145 SET state = 'running',
152 $sth = $dbh->prepare($r->{sql}->{'select'});
154 $sth->execute(@{ $r->{sql}->{'bind'} });
155 $r->{data} = $sth->fetchall_arrayref;
159 my $base = $doc->findvalue('/reporter/setup/files/output_base');
160 my $s1 = $r->{stage3}->{stage2}->{stage1};
161 my $s2 = $r->{stage3}->{stage2}->{id};
162 my $s3 = $r->{stage3}->{id};
163 my $output = $r->{id};
167 mkdir("$base/$s1/$s2");
168 mkdir("$base/$s1/$s2/$s3");
169 mkdir("$base/$s1/$s2/$s3/$output");
172 if (ref $p->{output_format}) {
173 @formats = @{ $p->{output_format} };
175 @formats = ( $p->{output_format} );
178 if ( grep { $_ eq 'csv' } @formats ) {
179 build_csv("$base/$s1/$s2/$s3/$output/report-data.csv", $r);
182 if ( grep { $_ eq 'excel' } @formats ) {
183 build_excel("$base/$s1/$s2/$s3/$output/report-data.xls", $r);
186 if ( grep { $_ eq 'html' } @formats ) {
187 mkdir("$base/$s1/$s2/$s3/$output/html");
188 build_html("$base/$s1/$s2/$s3/$output/report-data.html", $r);
193 $dbh->do(<<' SQL',{}, $r->{stage3}->{id});
194 UPDATE reporter.stage3
195 SET runtime = runtime + recurrence
196 WHERE id = ? AND recurrence > '0 seconds'::INTERVAL;
198 $dbh->do(<<' SQL',{}, $r->{stage3}->{id});
199 UPDATE reporter.stage3
201 WHERE id = ? AND rerun = TRUE;
203 $dbh->do(<<' SQL',{}, $r->{id});
204 UPDATE reporter.output
205 SET state = 'complete',
206 complete_time = 'now'
215 $dbh->do(<<' SQL',{}, $e, $r->{id});
216 UPDATE reporter.output
227 exit; # leave the child
232 POSIX::waitpid( -1, POSIX::WNOHANG );
237 #-------------------------------------------------------------------
242 my $settings = $r->{sql};
243 my $data = $r->{data};
245 return unless (defined($settings->{pivot}));
247 my @groups = (map { ($_ - 1) } @{ $settings->{groupby} });
248 my @values = (0 .. (scalar(@{$settings->{columns}}) - 1));
249 splice(@values,$_,1) for (reverse @groups);
251 # remove pivot from group-by
254 while ($count < scalar(@{$settings->{groupby}})) {
255 if (defined $pivot_groupby) {
256 $settings->{groupby}->[$count] -= 1;
257 if ($settings->{groupby}->[$count] >= $values[0] + 1) {
258 $settings->{groupby}->[$count] -= 1;
260 } elsif ($settings->{groupby}->[$count] == $settings->{pivot} + 1) {
261 $pivot_groupby = $count;
267 # grab positions of non-group-bys
268 @values = (0 .. (scalar(@{$settings->{columns}}) - 1));
269 splice(@values,$_,1) for (reverse @groups);
271 # we're only doing one "value" for now, so grab that and remove from headings
272 my ($val_col) = @values;
276 ($val_col, $settings->{groupby}->[$pivot_groupby] - 1);
279 for my $row (@$data) {
280 $p_header{ $$row[$settings->{pivot}] } = [] unless exists($p_header{ $$row[$settings->{pivot}] });
282 push @{ $p_header{ $$row[$settings->{pivot}] } }, $$row[$val_col];
284 splice(@$row,$_,1) for (@remove_me);
287 push @{ $settings->{columns} }, sort keys %p_header;
289 # remove from headings;
290 splice(@{$settings->{columns}},$_,1) for (@remove_me);
292 # remove pivot from groupby
293 splice(@{$settings->{groupby}}, $pivot_groupby, 1);
294 @groups = (map { ($_ - 1) } @{ $settings->{groupby} });
296 $count = scalar(keys %p_header);
300 for my $row (@$data) {
302 my $fingerprint = join('',@$row[@groups]);
303 next if $seenit{$fingerprint};
305 $seenit{$fingerprint}++;
307 for my $h ( sort keys %p_header ) {
308 push @$row, shift(@{ $p_header{$h} });
311 push @new_data, [@$row];
315 #replace old data with new
316 $r->{data} = \@new_data;
324 my $csv = Text::CSV_XS->new({ always_quote => 1, eol => "\015\012" });
325 my $f = new FileHandle (">$file");
327 $csv->print($f, $r->{sql}->{columns});
328 $csv->print($f, $_) for (@{$r->{data}});
335 my $p = JSON->JSON2perl( $r->{stage3}->{params} );
337 my $xls = Spreadsheet::WriteExcel->new($file);
339 my $sheetname = substr($p->{reportname},1,31);
340 $sheetname =~ s/\W/_/gos;
342 my $sheet = $xls->add_worksheet($sheetname);
344 $sheet->write_row('A1', $r->{sql}->{columns});
346 $sheet->write_col('A2', $r->{data});
354 my $p = JSON->JSON2perl( $r->{stage3}->{params} );
356 my $index = new FileHandle (">$file");
357 my $raw = new FileHandle (">$file.raw.html");
360 print $index <<" HEADER";
363 <title>$$p{reportname}</title>
365 table { border-collapse: collapse; }
366 th { background-color: lightgray; }
367 td,th { border: solid black 1px; }
368 * { font-family: sans-serif; font-size: 10px; }
372 <h2><u>$$p{reportname}</u></h2>
376 # add a link to the raw output html
377 print $index "<a href='report-data.html.raw.html'>Raw output data</a><br/><br/><br/><br/>";
379 # create the raw output html file
380 print $raw "<html><head><title>$$p{reportname}</title>";
384 table { border-collapse: collapse; }
385 th { background-color: lightgray; }
386 td,th { border: solid black 1px; }
387 * { font-family: sans-serif; font-size: 10px; }
391 print $raw "</head><body><table>";
394 print $raw "<tr><th>".join('</th><th>',@{$r->{sql}->{columns}}).'</th></tr>';
395 print $raw "<tr><td>".join('</td><td>',@$_ ).'</td></tr>' for (@{$r->{data}});
398 print $raw '</table></body></html>';
402 # get the graph types
404 if (ref $$p{html_graph_type}) {
405 @graphs = @{ $$p{html_graph_type} };
407 @graphs = ( $$p{html_graph_type} );
410 # Time for a pie chart
411 if (grep {$_ eq 'pie'} @graphs) {
412 my $pics = draw_pie($r, $p, $file);
413 for my $pic (@$pics) {
414 print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/><br/><br/><br/><br/>";
418 print $index '<br/><br/><br/><br/>';
419 # Time for a bar chart
420 if (grep {$_ eq 'bar'} @graphs) {
421 my $pics = draw_bars($r, $p, $file);
422 for my $pic (@$pics) {
423 print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/><br/><br/><br/><br/>";
429 print $index '</body></html>';
438 my $data = $r->{data};
439 my $settings = $r->{sql};
441 my @groups = (map { ($_ - 1) } @{ $settings->{groupby} });
443 my @values = (0 .. (scalar(@{$settings->{columns}}) - 1));
444 delete @values[@groups];
446 my $logo = $doc->findvalue('/reporter/setup/files/chart_logo');
449 for my $vcol (@values) {
450 next unless (defined $vcol);
452 my @pic_data = ([],[]);
453 for my $row (@$data) {
454 next if (!defined($$row[$vcol]) || $$row[$vcol] == 0);
455 push @{$pic_data[0]}, join(" -- ", @$row[@groups]);
456 push @{$pic_data[1]}, $$row[$vcol];
459 next unless (@{$pic_data[0]});
462 my $split = int(scalar(@{$pic_data[0]}) / $size);
463 my $last = scalar(@{$pic_data[0]}) % $size;
465 for my $sub_graph (0 .. $split) {
467 if ($sub_graph == $split) {
472 for my $set (@pic_data) {
473 push @sub_data, [ splice(@$set,0,$size) ];
476 my $pic = new GD::Graph::pie;
479 label => $settings->{columns}->[$vcol],
481 legend_placement => 'R',
483 logo_position => 'TL',
488 my $format = $pic->export_format;
490 open(IMG, ">$file.pie.$vcol.$sub_graph.$format");
495 $pic->plot(\@sub_data) or die $pic->error;
496 print IMG $pic->gd->$format;
499 warn "Couldn't draw $file.pie.$vcol.$sub_graph.$format : $e";
507 { file => "pie.$vcol.$sub_graph.$format",
508 name => $settings->{columns}->[$vcol].' (Pie)',
509 } unless ($forgetit);
511 last if ($sub_graph == $split);
523 my $data = $r->{data};
524 my $settings = $r->{sql};
526 my $logo = $doc->findvalue('/reporter/setup/files/chart_logo');
528 my @groups = (map { ($_ - 1) } @{ $settings->{groupby} });
531 my @values = (0 .. (scalar(@{$settings->{columns}}) - 1));
532 splice(@values,$_,1) for (reverse @groups);
536 for my $row (@$data) {
537 push @{$pic_data[0]}, join(' -- ', @$row[@groups]);
547 for my $vcol (@values) {
548 next unless (defined $vcol);
552 for my $row (@$data) {
553 my $val = $$row[$vcol] ? $$row[$vcol] : 0;
554 push @{$pic_data[$set]}, $val;
555 $max_y = $val if ($val > $max_y);
556 $trim_candidates{$pos}++ if ($val == 0);
562 my $set_count = scalar(@pic_data) - 1;
563 my @trim_cols = grep { $trim_candidates{$_} == $set_count } keys %trim_candidates;
569 for my $dataset (@pic_data) {
570 splice(@$dataset,$_,1) for (sort { $b <=> $a } @trim_cols);
572 if (grep { $_ } @$dataset) {
573 push @new_data, $dataset;
574 push @use_me, $set_index;
576 push @no_use, $set_index;
582 for my $col (@use_me) {
583 push @leg, $settings->{columns}->[$col + @groups - 1] if (map { 1 } grep { $col == $_ } @values);
586 my $w = 100 + 10 * scalar(@{$new_data[0]});
587 $w = 400 if ($w < 400);
589 my $h = 10 * (scalar(@new_data) / 2);
593 my $pic = new GD::Graph::bars3d ($w + 250, $h + 500);
596 title => $p->{reportname},
597 x_labels_vertical => 1,
601 y_max_value => $max_y,
602 legend_placement => 'TR',
605 logo_position => 'R',
610 $pic->set_legend(@leg);
612 my $format = $pic->export_format;
614 open(IMG, ">$file.bar.$format");
618 $pic->plot(\@new_data) or die $pic->error;
619 print IMG $pic->gd->$format;
622 warn "Couldn't draw $file.bar.$format : $e";
627 return [{ file => "bar.$format",
628 name => $p->{reportname}.' (Bar)',
635 my ($node) = $doc->findnodes("//*[\@id='$id']");
636 if ($node && $node->findvalue('@table')) {
637 ($node) = $doc->findnodes("//*[\@id='".$node->getAttribute('table')."']");
645 my $p = JSON->JSON2perl( $r->{stage3}->{params} );
649 my $core = $r->{stage3}->{stage2}->{stage1};
652 for my $t (keys %{$$p{filter}}) {
658 for my $t (keys %{$$p{output}}) {
659 if ($t ne $core && !(grep { $t eq $_ } @dims) ) {
667 my $t = table_by_id($d);
668 my $t_name = $t->findvalue('tablename');
669 push @dim_from, "$t_name AS \"$d\"";
671 my $k = $doc->findvalue("//*[\@id='$d']/\@key");
672 push @dim_select, "\"$d\".\"$k\" AS \"${d}_${k}\"";
674 for my $c ( keys %{$$p{output}{$d}} ) {
675 push @dim_select, "\"$d\".\"$c\" AS \"${d}_${c}\"";
678 for my $c ( keys %{$$p{filter}{$d}} ) {
679 next if (exists $$p{output}{$d}{$c});
680 push @dim_select, "\"$d\".\"$c\" AS \"${d}_${c}\"";
685 '(SELECT ' . join(',', @dim_select) .
686 ' FROM ' . join(',', @dim_from) . ') AS dims';
689 if (ref $$p{output_order}) {
690 @opord = @{ $$p{output_order} };
692 @opord = ( $$p{output_order} );
694 my @output_order = map { { (split ':')[1] => (split ':')[2] } } @opord;
695 my @p_col = split(':',$p->{pivot_col}) if $p->{pivot_col};
704 for my $pair (@output_order) {
705 my ($t_name) = keys %$pair;
708 $t_name = "dims" if ($t ne $core);
710 my $t_node = table_by_id($t);
712 for my $c ( values %$pair ) {
713 my $label = $t_node->findvalue("fields/field[\@name='$c']/label");
716 $full_col = "${t}_${c}" if ($t ne $t_name);
717 $full_col = "\"$t_name\".\"$full_col\"";
720 if (my $xform_type = $$p{xform}{type}{$t}{$c}) {
721 my $xform = $$OpenILS::WWW::Reporter::dtype_xforms{$xform_type};
722 if ($xform->{group}) {
725 $label = "$$xform{label} -- $label";
727 my $tmp = $xform->{'select'};
728 $tmp =~ s/\?COLNAME\?/$full_col/gs;
729 $tmp =~ s/\?PARAM\?/$$p{xform}{param}{$t}{$c}/gs;
735 push @output, "$full_col AS \"$label\"";
736 push @columns, $label;
737 $pivot = scalar(@columns) - 1 if (@p_col && $t eq $p_col[1] && $c eq $p_col[2]);
741 if ($t ne $t_name && (!@join_base || !grep{$t eq $_}@join_base)) {
742 my $k = $doc->findvalue("//*[\@id='$t']/\@key");
743 my $f = $doc->findvalue("//*[\@id='$t']/\@field");
744 push @join, "dims.\"${t}_${k}\" = \"$core\".\"$f\"";
751 for my $t ( keys %{$$p{filter}} ) {
753 $t_name = "dims" if ($t ne $core);
755 my $t_node = table_by_id($t);
757 for my $c ( keys %{$$p{filter}{$t}} ) {
758 my $label = $t_node->findvalue("fields/field[\@name='$c']/label");
761 $full_col = "${t}_${c}" if ($t ne $t_name);
762 $full_col = "\"$t_name\".\"$full_col\"";
764 # XXX make this use widget specific code
766 my ($fam) = keys %{ $$p{filter}{$t}{$c} };
767 my ($w) = keys %{ $$p{filter}{$t}{$c}{$fam} };
768 my $val = $$p{filter}{$t}{$c}{$fam}{$w};
771 push @where, "$full_col IN (".join(",",map {'?'}@$val).")";
774 push @where, "$full_col = ?";
779 if ($t ne $t_name && (!@join_base || !grep{$t eq $_}@join_base)) {
780 my $k = $doc->findvalue("//*[\@id='$t']/\@key");
781 my $f = $doc->findvalue("//*[\@id='$t']/\@field");
782 push @join, "dims.\"${t}_${k}\" = \"$core\".\"$f\"";
787 my $t = table_by_id($core)->findvalue('tablename');
789 my $from = " FROM $t AS \"$core\" ";
790 $from .= "RIGHT JOIN $d_select ON (". join(' AND ', @join).")" if ( @join );
793 "SELECT ".join(',', @output). $from;
795 $select .= ' WHERE '.join(' AND ', @where) if (@where);
796 $select .= ' GROUP BY '.join(',',@groupby) if (@groupby);
798 $r->{sql}->{'pivot'} = $pivot;
799 $r->{sql}->{'select'} = $select;
800 $r->{sql}->{'bind'} = \@bind;
801 $r->{sql}->{columns} = \@columns;
802 $r->{sql}->{groupby} = \@groupby;