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
63 AND id NOT IN ( SELECT stage3 FROM reporter.output ) )
64 OR ( recurrence > '0 seconds'::INTERVAL
68 WHERE state <> 'complete')
74 # make sure we're not already running $count reports
75 my ($running) = $dbh->selectrow_array(<<SQL);
78 WHERE state = 'running';
81 if ($count <= $running) {
85 POSIX::waitpid( -1, POSIX::WNOHANG );
89 print "Already running maximum ($running) concurrent reports\n";
93 # if we have some open slots then generate the sql
94 my $run = $count - $running;
96 my $sth = $dbh->prepare(<<SQL);
107 while (my $r = $sth->fetchrow_hashref) {
108 my $s3 = $dbh->selectrow_hashref(<<" SQL", {}, $r->{stage3});
109 SELECT * FROM reporter.stage3 WHERE id = ?;
112 my $s2 = $dbh->selectrow_hashref(<<" SQL", {}, $s3->{stage2});
113 SELECT * FROM reporter.stage2 WHERE id = ?;
119 generate_query( $r );
127 # Now we spaun the report runners
129 for my $r ( @reports ) {
130 next if (safe_fork());
132 # This is the child (runner) process;
133 my $p = JSON->JSON2perl( $r->{stage3}->{params} );
134 daemonize("Clark Kent reporting: $p->{reportname}");
136 $dbh = DBI->connect($dsn,$db_user,$db_pw, {pg_enable_utf8 => 1, RaiseError => 1});
139 $dbh->do(<<' SQL',{}, $r->{sql}->{'select'}, $$, $r->{id});
140 UPDATE reporter.output
141 SET state = 'running',
148 $sth = $dbh->prepare($r->{sql}->{'select'});
150 $sth->execute(@{ $r->{sql}->{'bind'} });
151 $r->{data} = $sth->fetchall_arrayref;
153 my $base = $doc->findvalue('/reporter/setup/files/output_base');
154 my $s1 = $r->{stage3}->{stage2}->{stage1};
155 my $s2 = $r->{stage3}->{stage2}->{id};
156 my $s3 = $r->{stage3}->{id};
157 my $output = $r->{id};
161 mkdir("$base/$s1/$s2");
162 mkdir("$base/$s1/$s2/$s3");
163 mkdir("$base/$s1/$s2/$s3/$output");
166 if (ref $p->{output_format}) {
167 @formats = @{ $p->{output_format} };
169 @formats = ( $p->{output_format} );
172 if ( grep { $_ eq 'csv' } @formats ) {
173 build_csv("$base/$s1/$s2/$s3/$output/report-data.csv", $r);
176 if ( grep { $_ eq 'excel' } @formats ) {
177 build_excel("$base/$s1/$s2/$s3/$output/report-data.xls", $r);
180 if ( grep { $_ eq 'html' } @formats ) {
181 mkdir("$base/$s1/$s2/$s3/$output/html");
182 build_html("$base/$s1/$s2/$s3/$output/report-data.html", $r);
187 $dbh->do(<<' SQL',{}, $r->{stage3}->{id});
188 UPDATE reporter.stage3
189 SET runtime = runtime + recurrence
190 WHERE id = ? AND recurrence > '0 seconds'::INTERVAL;
192 $dbh->do(<<' SQL',{}, $r->{id});
193 UPDATE reporter.output
194 SET state = 'complete',
195 complete_time = 'now'
204 $dbh->do(<<' SQL',{}, $e, $r->{id});
205 UPDATE reporter.output
216 exit; # leave the child
221 POSIX::waitpid( -1, POSIX::WNOHANG );
226 #-------------------------------------------------------------------
232 my $csv = Text::CSV_XS->new({ always_quote => 1, eol => "\015\012" });
233 my $f = new FileHandle (">$file");
235 $csv->print($f, $r->{sql}->{columns});
236 $csv->print($f, $_) for (@{$r->{data}});
243 my $p = JSON->JSON2perl( $r->{stage3}->{params} );
245 my $xls = Spreadsheet::WriteExcel->new($file);
247 my $sheetname = substr($p->{reportname},1,31);
248 $sheetname =~ s/\W/_/gos;
250 my $sheet = $xls->add_worksheet($sheetname);
252 $sheet->write_row('A1', $r->{sql}->{columns});
254 $sheet->write_col('A2', $r->{data});
262 my $p = JSON->JSON2perl( $r->{stage3}->{params} );
264 my $index = new FileHandle (">$file");
265 my $raw = new FileHandle (">$file.raw.html");
268 print $index <<" HEADER";
271 <title>$$p{reportname}</title>
273 table { border-collapse: collapse; }
274 th { background-color: lightgray; }
275 td,th { border: solid black 1px; }
276 * { font-family: sans-serif; font-size: 10px; }
280 <h2><u>$$p{reportname}</u></h2>
284 # add a link to the raw output html
285 print $index "<a href='report-data.html.raw.html'>Raw output data</a><br/><br/><br/><br/>";
287 # create the raw output html file
288 print $raw "<html><head><title>$$p{reportname}</title>";
292 table { border-collapse: collapse; }
293 th { background-color: lightgray; }
294 td,th { border: solid black 1px; }
295 * { font-family: sans-serif; font-size: 10px; }
299 print $raw "</head><body><table>";
300 print $raw "<tr><th>".join('</th><th>',@{$r->{sql}->{columns}}).'</th></tr>';
302 print $raw "<tr><td>".join('</td><td>',@$_).'</td></tr>' for (@{$r->{data}});
304 print $raw '</table></body></html>';
308 # get the graph types
310 if (ref $$p{html_graph_type}) {
311 @graphs = @{ $$p{html_graph_type} };
313 @graphs = ( $$p{html_graph_type} );
316 # Time for a pie chart
317 if (grep {$_ eq 'pie'} @graphs) {
318 my $pics = draw_pie($r, $p, $file);
319 for my $pic (@$pics) {
320 print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/><br/><br/><br/><br/>";
324 # Time for a bar chart
325 if (grep {$_ eq 'bar'} @graphs) {
326 my $pics = draw_bars($r, $p, $file);
327 for my $pic (@$pics) {
328 print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/><br/><br/><br/><br/>";
334 print $index '</body></html>';
343 my $data = $r->{data};
344 my $settings = $r->{sql};
346 my @groups = (map { ($_ - 1) } @{ $settings->{groupby} });
348 my @values = (0 .. (scalar(@{$settings->{columns}}) - 1));
349 delete @values[@groups];
352 for my $vcol (@values) {
353 next unless (defined $vcol);
356 for my $row (@$data) {
357 next if ($$row[$vcol] == 0);
358 push @{$pic_data[0]}, join(' -- ', @$row[@groups]);
359 push @{$pic_data[1]}, $$row[$vcol];
362 my $pic = new GD::Graph::pie;
365 label => $p->{reportname}." -- ".$settings->{columns}->[$vcol],
367 legend_placement=> 'R'
370 my $format = $pic->export_format;
372 open(IMG, ">$file.pie.$vcol.$format");
377 $pic->plot(\@pic_data) or die $pic->error;
378 print IMG $pic->gd->$format;
381 warn "Couldn't draw $file.pie.$vcol.$format : $e";
390 { file => "pie.$vcol.$format",
391 name => $p->{reportname}." -- ".$settings->{columns}->[$vcol].' (Pie)',
403 my $data = $r->{data};
404 my $settings = $r->{sql};
406 my @groups = (map { ($_ - 1) } @{ $settings->{groupby} });
408 my @values = (0 .. (scalar(@{$settings->{columns}}) - 1));
409 delete @values[@groups];
412 for my $row (@$data) {
413 push @{$pic_data[0]}, join(' -- ', @$row[@groups]);
422 for my $vcol (@values) {
423 next unless (defined $vcol);
425 push @leg, $settings->{columns}->[$vcol];
428 for my $row (@$data) {
429 my $val = $$row[$vcol] ? $$row[$vcol] : 0;
430 push @{$pic_data[$set]}, $val;
431 $max_y = $val if ($val > $max_y);
432 $trim_candidates{$pos}++ if ($val == 0);
438 my $set_count = scalar(@pic_data) - 1;
439 my @trim_cols = grep { $trim_candidates{$_} == $set_count } keys %trim_candidates;
441 for my $dataset (@pic_data) {
442 for my $col (reverse sort { $a <=> $b } @trim_cols) {
443 splice(@$dataset,$col,1);
447 my $w = 100 + 10 * scalar(@{$pic_data[0]});
448 $w = 400 if ($w < 400);
450 my $pic = new GD::Graph::bars3d ($w, 500);
453 title => $p->{reportname},
454 x_labels_vertical => 1,
458 y_max_value => $max_y,
459 legend_placement => 'BL',
462 $pic->set_legend(@leg);
464 my $format = $pic->export_format;
466 open(IMG, ">$file.bar.$format");
471 $pic->plot(\@pic_data) or die $pic->error;
472 print IMG $pic->gd->$format;
475 warn "Couldn't draw $file.bar.$format : $e";
483 return [{ file => "bar.$format",
484 name => $p->{reportname}.' (Bar)',
491 my ($node) = $doc->findnodes("//*[\@id='$id']");
492 if ($node && $node->findvalue('@table')) {
493 ($node) = $doc->findnodes("//*[\@id='".$node->getAttribute('table')."']");
501 my $p = JSON->JSON2perl( $r->{stage3}->{params} );
505 my $core = $r->{stage3}->{stage2}->{stage1};
508 for my $t (keys %{$$p{filter}}) {
514 for my $t (keys %{$$p{output}}) {
515 if ($t ne $core && !grep { $t } @dims ) {
523 my $t = table_by_id($d);
524 my $t_name = $t->findvalue('tablename');
525 push @dim_from, "$t_name AS \"$d\"";
527 my $k = $doc->findvalue("//*[\@id='$d']/\@key");
528 push @dim_select, "\"$d\".\"$k\" AS \"${d}_${k}\"";
530 for my $c ( keys %{$$p{output}{$d}} ) {
531 push @dim_select, "\"$d\".\"$c\" AS \"${d}_${c}\"";
534 for my $c ( keys %{$$p{filter}{$d}} ) {
535 next if (exists $$p{output}{$d}{$c});
536 push @dim_select, "\"$d\".\"$c\" AS \"${d}_${c}\"";
541 '(SELECT ' . join(',', @dim_select) .
542 ' FROM ' . join(',', @dim_from) . ') AS dims';
545 if (ref $$p{output_order}) {
546 @opord = @{ $$p{output_order} };
548 @opord = ( $$p{output_order} );
550 my @output_order = map { { (split ':')[1] => (split ':')[2] } } @opord;
558 for my $pair (@output_order) {
559 my ($t_name) = keys %$pair;
562 $t_name = "dims" if ($t ne $core);
564 my $t_node = table_by_id($t);
566 for my $c ( values %$pair ) {
567 my $label = $t_node->findvalue("fields/field[\@name='$c']/label");
570 $full_col = "${t}_${c}" if ($t ne $t_name);
571 $full_col = "\"$t_name\".\"$full_col\"";
574 if (my $xform_type = $$p{xform}{type}{$t}{$c}) {
575 my $xform = $$OpenILS::WWW::Reporter::dtype_xforms{$xform_type};
576 if ($xform->{group}) {
579 $label = "$$xform{label} -- $label";
581 my $tmp = $xform->{'select'};
582 $tmp =~ s/\?COLNAME\?/$full_col/gs;
583 $tmp =~ s/\?PARAM\?/$$p{xform}{param}{$t}{$c}/gs;
589 push @output, "$full_col AS \"$label\"";
590 push @columns, $label;
594 if ($t ne $t_name && (!@join_base || !grep{$t eq $_}@join_base)) {
595 my $k = $doc->findvalue("//*[\@id='$t']/\@key");
596 my $f = $doc->findvalue("//*[\@id='$t']/\@field");
597 push @join, "dims.\"${t}_${k}\" = \"$core\".\"$f\"";
604 for my $t ( keys %{$$p{filter}} ) {
606 $t_name = "dims" if ($t ne $core);
608 my $t_node = table_by_id($t);
610 for my $c ( keys %{$$p{filter}{$t}} ) {
611 my $label = $t_node->findvalue("fields/field[\@name='$c']/label");
614 $full_col = "${t}_${c}" if ($t ne $t_name);
615 $full_col = "\"$t_name\".\"$full_col\"";
617 # XXX make this use widget specific code
619 my ($fam) = keys %{ $$p{filter}{$t}{$c} };
620 my ($w) = keys %{ $$p{filter}{$t}{$c}{$fam} };
621 my $val = $$p{filter}{$t}{$c}{$fam}{$w};
624 push @where, "$full_col IN (".join(",",map {'?'}@$val).")";
627 push @where, "$full_col = ?";
632 if ($t ne $t_name && (!@join_base || !grep{$t eq $_}@join_base)) {
633 my $k = $doc->findvalue("//*[\@id='$t']/\@key");
634 my $f = $doc->findvalue("//*[\@id='$t']/\@field");
635 push @join, "dims.\"${t}_${k}\" = \"$core\".\"$f\"";
640 my $t = table_by_id($core)->findvalue('tablename');
641 my $from = " FROM $t AS \"$core\" RIGHT JOIN $d_select ON (". join(' AND ', @join).")";
643 "SELECT ".join(',', @output). $from;
645 $select .= ' WHERE '.join(' AND ', @where) if (@where);
646 $select .= ' GROUP BY '.join(',',@groupby) if (@groupby);
648 $r->{sql}->{'select'} = $select;
649 $r->{sql}->{'bind'} = \@bind;
650 $r->{sql}->{columns} = \@columns;
651 $r->{sql}->{groupby} = \@groupby;