10 use DateTime::Format::ISO8601;
13 use Spreadsheet::WriteExcel::Big;
14 use OpenSRF::EX qw/:try/;
15 use OpenSRF::Utils qw/:daemon/;
16 use OpenSRF::Utils::JSON;
17 use OpenSRF::Utils::Logger qw/$logger/;
19 use OpenSRF::AppSession;
20 use OpenSRF::Utils::SettingsClient;
21 use OpenILS::Reporter::SQLBuilder;
24 use GD::Graph::bars3d;
25 use GD::Graph::lines3d;
32 my ($count, $config, $sleep_interval, $lockfile, $daemon) = (1, 'SYSCONFDIR/opensrf_core.xml', 10, '/tmp/reporter-LOCK');
36 "sleep=i" => \$sleep_interval,
37 "concurrency=i" => \$count,
38 "bootstrap|boostrap=s" => \$config,
39 "lockfile=s" => \$lockfile,
43 die "I seem to be running already. If not, remove $lockfile and try again\n";
46 OpenSRF::System->bootstrap_client( config_file => $config );
48 my (%data_db, %state_db);
50 my $sc = OpenSRF::Utils::SettingsClient->new;
52 $data_db{db_driver} = $sc->config_value( reporter => setup => database => 'driver' );
53 $data_db{db_host} = $sc->config_value( reporter => setup => database => 'host' );
54 $data_db{db_port} = $sc->config_value( reporter => setup => database => 'port' );
55 $data_db{db_name} = $sc->config_value( reporter => setup => database => 'db' );
56 if (!$data_db{db_name}) {
57 $data_db{db_name} = $sc->config_value( reporter => setup => database => 'name' );
58 print STDERR "WARN: <database><name> is a deprecated setting for database name. For future compatibility, you should use <database><db> instead." if $data_db{db_name};
60 $data_db{db_user} = $sc->config_value( reporter => setup => database => 'user' );
61 $data_db{db_pw} = $sc->config_value( reporter => setup => database => 'pw' );
65 # Fetch the optional state database connection info
66 $state_db{db_driver} = $sc->config_value( reporter => setup => state_store => 'driver' ) || $data_db{db_driver};
67 $state_db{db_host} = $sc->config_value( reporter => setup => state_store => 'host' ) || $data_db{db_host};
68 $state_db{db_port} = $sc->config_value( reporter => setup => state_store => 'port' ) || $data_db{db_port};
69 $state_db{db_name} = $sc->config_value( reporter => setup => state_store => 'db' );
70 if (!$state_db{db_name}) {
71 $state_db{db_name} = $sc->config_value( reporter => setup => state_store => 'name' ) || $data_db{db_name};
73 $state_db{db_user} = $sc->config_value( reporter => setup => state_store => 'user' ) || $data_db{db_user};
74 $state_db{db_pw} = $sc->config_value( reporter => setup => state_store => 'pw' ) || $data_db{db_pw};
77 die "Unable to retrieve database connection information from the settings server"
78 unless ($state_db{db_driver} && $state_db{db_host} && $state_db{db_port} && $state_db{db_name} && $state_db{db_user} &&
79 $data_db{db_driver} && $data_db{db_host} && $data_db{db_port} && $data_db{db_name} && $data_db{db_user});
81 my $email_server = $sc->config_value( email_notify => 'smtp_server' );
82 my $email_sender = $sc->config_value( email_notify => 'sender_address' );
83 my $success_template = $sc->config_value( reporter => setup => files => 'success_template' );
84 my $fail_template = $sc->config_value( reporter => setup => files => 'fail_template' );
85 my $output_base = $sc->config_value( reporter => setup => files => 'output_base' );
86 my $base_uri = $sc->config_value( reporter => setup => 'base_uri' );
88 my $state_dsn = "dbi:" . $state_db{db_driver} . ":dbname=" . $state_db{db_name} .';host=' . $state_db{db_host} . ';port=' . $state_db{db_port};
89 my $data_dsn = "dbi:" . $data_db{db_driver} . ":dbname=" . $data_db{db_name} .';host=' . $data_db{db_host} . ';port=' . $data_db{db_port};
91 my ($dbh,$running,$sth,@reports,$run, $current_time);
94 open(F, ">$lockfile") or die "Cannot write lockfile '$lockfile'";
97 daemonize("Clark Kent, waiting for trouble");
108 pg_expand_array => 0,
114 $current_time = DateTime->from_epoch( epoch => time() )->strftime('%FT%T%z');
116 # make sure we're not already running $count reports
117 ($running) = $dbh->selectrow_array(<<SQL);
119 FROM reporter.schedule
120 WHERE start_time IS NOT NULL AND complete_time IS NULL;
123 if ($count <= $running) {
127 POSIX::waitpid( -1, POSIX::WNOHANG );
128 sleep $sleep_interval;
131 print "Already running maximum ($running) concurrent reports\n";
135 # if we have some open slots then generate the sql
136 $run = $count - $running;
138 $sth = $dbh->prepare(<<SQL);
140 FROM reporter.schedule
141 WHERE start_time IS NULL AND run_time < NOW()
149 while (my $r = $sth->fetchrow_hashref) {
150 my $s3 = $dbh->selectrow_hashref(<<" SQL", {}, $r->{report});
151 SELECT * FROM reporter.report WHERE id = ?;
154 my $s2 = $dbh->selectrow_hashref(<<" SQL", {}, $s3->{template});
155 SELECT * FROM reporter.template WHERE id = ?;
158 $s3->{template} = $s2;
161 my $b = OpenILS::Reporter::SQLBuilder->new;
162 my $report_data = OpenSRF::Utils::JSON->JSON2perl( $r->{report}->{data} );
163 $b->register_params( $report_data );
165 $r->{resultset} = $b->parse_report( OpenSRF::Utils::JSON->JSON2perl( $r->{report}->{template}->{data} ) );
166 $r->{resultset}->set_pivot_data($report_data->{__pivot_data}) if $report_data->{__pivot_data};
167 $r->{resultset}->set_pivot_label($report_data->{__pivot_label}) if $report_data->{__pivot_label};
168 $r->{resultset}->set_pivot_default($report_data->{__pivot_default}) if $report_data->{__pivot_default};
169 $r->{resultset}->relative_time($r->{run_time});
177 # Now we spawn the report runners
179 for my $r ( @reports ) {
180 next if (safe_fork());
182 # This is the child (runner) process;
183 daemonize("Clark Kent reporting: $r->{report}->{name}");
185 my $state_dbh = DBI->connect(
190 pg_expand_array => 0,
196 my $data_dbh = DBI->connect(
201 pg_expand_array => 0,
208 $state_dbh->do(<<' SQL',{}, $r->{id});
209 UPDATE reporter.schedule
210 SET start_time = now()
214 $logger->debug('Report SQL: ' . $r->{resultset}->toSQL);
215 $sth = $data_dbh->prepare($r->{resultset}->toSQL);
218 $r->{data} = $sth->fetchall_arrayref;
220 $r->{column_labels} = [$r->{resultset}->column_label_list];
222 if ($r->{resultset}->pivot_data && $r->{resultset}->pivot_label) {
223 my @labels = $r->{resultset}->column_label_list;
224 my $newdata = pivot_data(
225 { columns => $r->{column_labels}, data => $r->{data}},
226 $r->{resultset}->pivot_label,
227 $r->{resultset}->pivot_data,
228 $r->{resultset}->pivot_default
231 $r->{column_labels} = $newdata->{columns};
232 $r->{data} = $newdata->{data};
233 $r->{group_by_list} = $newdata->{group_by_list};
235 $r->{group_by_list} = [$r->{resultset}->group_by_list(0)];
238 my $s2 = $r->{report}->{template}->{id};
239 my $s3 = $r->{report}->{id};
240 my $output = $r->{id};
243 mkdir("$output_base/$s2");
244 mkdir("$output_base/$s2/$s3");
245 mkdir("$output_base/$s2/$s3/$output");
247 my $output_dir = "$output_base/$s2/$s3/$output";
249 if ( $r->{csv_format} ) {
250 build_csv("$output_dir/report-data.csv", $r);
253 if ( $r->{excel_format} ) {
254 build_excel("$output_dir/report-data.xls", $r);
257 build_html("$output_dir/report-data.html", $r);
259 $state_dbh->begin_work;
261 if ($r->{report}->{recur} ) {
263 INSERT INTO reporter.schedule (
275 VALUES ( ?, ?, ?, ?::TIMESTAMPTZ + ?, ?, ?, ?, ?, ?, ?, ? );
285 $r->{report}->{recurrence},
296 $state_dbh->do(<<' SQL',{}, $r->{id});
297 UPDATE reporter.schedule
298 SET complete_time = now()
304 my $new_r = $state_dbh->selectrow_hashref(<<" SQL", {}, $r->{id});
305 SELECT * FROM reporter.schedule WHERE id = ?;
308 $r->{start_time} = $new_r->{start_time};
309 $r->{complete_time} = $new_r->{complete_time};
317 $r->{error_text} = ''.$e;
318 if (!$state_dbh->{AutoCommit}) {
319 $state_dbh->rollback;
321 $state_dbh->do(<<' SQL',{}, $e, $r->{id});
322 UPDATE reporter.schedule
324 complete_time = now(),
329 my $new_r = $state_dbh->selectrow_hashref(<<" SQL", {}, $r->{id});
330 SELECT * FROM reporter.schedule WHERE id = ?;
333 $r->{error_text} = $new_r->{error_text};
334 $r->{complete_time} = $new_r->{complete_time};
342 $state_dbh->disconnect;
343 $data_dbh->disconnect;
345 exit; # leave the child
350 POSIX::waitpid( -1, POSIX::WNOHANG );
351 sleep $sleep_interval;
355 #-------------------------------------------------------------------
359 open F, $success_template or die "Cannot read '$success_template'";
360 my $tmpl = join('',<F>);
363 my $url = $base_uri . '/' .
364 $r->{report}->{template}->{id} . '/' .
365 $r->{report}->{id} . '/' .
366 $r->{id} . '/report-data.html';
368 $tmpl =~ s/{TO}/$r->{email}/smog;
369 $tmpl =~ s/{FROM}/$email_sender/smog;
370 $tmpl =~ s/{REPLY_TO}/$email_sender/smog;
371 $tmpl =~ s/{REPORT_NAME}/$r->{report}->{name} -- $r->{report}->{template}->{name}/smog;
372 $tmpl =~ s/{RUN_TIME}/$r->{run_time}/smog;
373 $tmpl =~ s/{COMPLETE_TIME}/$r->{complete_time}/smog;
374 $tmpl =~ s/{OUTPUT_URL}/$url/smog;
376 my $sender = Email::Send->new({mailer => 'SMTP'});
377 $sender->mailer_args([Host => $email_server]);
378 $sender->send($tmpl);
383 open F, $fail_template or die "Cannot read '$fail_template'";
384 my $tmpl = join('',<F>);
387 my $sql = $r->{resultset}->toSQL;
389 $tmpl =~ s/{TO}/$r->{email}/smog;
390 $tmpl =~ s/{FROM}/$email_sender/smog;
391 $tmpl =~ s/{REPLY_TO}/$email_sender/smog;
392 $tmpl =~ s/{REPORT_NAME}/$r->{report}->{name} -- $r->{report}->{template}->{name}/smog;
393 $tmpl =~ s/{RUN_TIME}/$r->{run_time}/smog;
394 $tmpl =~ s/{ERROR_TEXT}/$r->{error_text}/smog;
395 $tmpl =~ s/{SQL}/$sql/smog;
397 my $sender = Email::Send->new({mailer => 'SMTP'});
398 $sender->mailer_args([Host => $email_server]);
399 $sender->send($tmpl);
406 my $csv = Text::CSV_XS->new({ always_quote => 1, eol => "\015\012" });
408 return unless ($csv);
410 my $f = new FileHandle (">$file") or die "Cannot write to '$file'";
412 $csv->print($f, $r->{column_labels});
413 $csv->print($f, $_) for (@{$r->{data}});
420 my $xls = Spreadsheet::WriteExcel::Big->new($file);
422 my $sheetname = substr($r->{report}->{name},0,30);
423 $sheetname =~ s/\W/_/gos;
425 my $sheet = $xls->add_worksheet($sheetname);
426 # don't try to write formulas, just write anything that starts with = as a text cell
427 $sheet->add_write_handler(qr/^=/, sub { return shift->write_string(@_); } );
429 $sheet->write_row('A1', $r->{column_labels});
431 $sheet->write_col('A2', $r->{data});
440 my $index = new FileHandle (">$file") or die "Cannot write to '$file'";
443 print $index <<" HEADER";
446 <title>$$r{report}{name}</title>
448 table { border-collapse: collapse; }
449 th { background-color: lightgray; }
450 td,th { border: solid black 1px; }
451 * { font-family: sans-serif; font-size: 10px; }
452 .dim { color: lightblue; }
457 <h2><u>$$r{report}{name}</u></h2>
458 $$r{report}{description}<br/><br/><br/>
463 my $br4 = '<br/>' x 4;
464 # add a link to the raw output html
465 push @links, "<a href='report-data.html.raw.html'>Tabular Output</a>" if ($r->{html_format});
467 # add a link to the CSV output
468 push @links, "<a href='report-data.xls'>Excel Output</a>" if ($r->{excel_format});
470 # add a link to the CSV output
471 push @links, "<a href='report-data.csv'>CSV Output</a>" if ($r->{csv_format});
474 push @links, "<a class='dim' href='report-data.html.debug.html'>Debugging Info</a>";
476 my $debug = new FileHandle (">$file.debug.html") or die "Cannot write to '$file.debug.html'";
477 print $debug "<html><head><title>DEBUG: $$r{report}{name}</title></head><body>";
480 print $debug '<h1>Generated SQL</h1><pre>' . $r->{resultset}->toSQL() . "</pre><a href='$file'>Back to output index</a><hr/>";
481 print $debug '<h1>Template</h1><pre>' . Dumper( $r->{report}->{template} ) . "</pre><a href='$file'>Back to output index</a><hr/>";
482 print $debug '<h1>Template Data</h1><pre>' . Dumper( OpenSRF::Utils::JSON->JSON2perl( $r->{report}->{template}->{data} ) ) . "</pre><a href='$file'>Back to output index</a><hr/>";
483 print $debug '<h1>Report Parameter</h1><pre>' . Dumper( $r->{report} ) . "</pre><a href='$file'>Back to output index</a><hr/>";
484 print $debug '<h1>Report Parameter Data</h1><pre>' . Dumper( OpenSRF::Utils::JSON->JSON2perl( $r->{report}->{data} ) ) . "</pre><a href='$file'>Back to output index</a><hr/>";
485 print $debug '<h1>Report Run Time</h1><pre>' . $r->{resultset}->relative_time . "</pre><a href='$file'>Back to output index</a><hr/>";
486 print $debug '<h1>OpenILS::Reporter::SQLBuilder::ResultSet Object</h1><pre>' . Dumper( $r->{resultset} ) . "</pre><a href='$file'>Back to output index</a>";
489 print $debug '</body></html>';
493 print $index join(' -- ', @links);
494 print $index "$br4</center>";
496 if ($r->{html_format}) {
497 # create the raw output html file
498 my $raw = new FileHandle (">$file.raw.html") or die "Cannot write to '$file.raw.html'";
499 print $raw "<html><head><title>$$r{report}{name}</title>";
503 table { border-collapse: collapse; }
504 th { background-color: lightgray; }
505 td,th { border: solid black 1px; }
506 * { font-family: sans-serif; font-size: 10px; }
510 print $raw "</head><body><table>";
513 print $raw "<tr><th>".join('</th><th>',@{$r->{column_labels}}).'</th></tr>';
514 print $raw "<tr><td>".join('</td><td>',@$_ ).'</td></tr>' for (@{$r->{data}});
517 print $raw '</table></body></html>';
522 # Time for a pie chart
523 if ($r->{chart_pie}) {
524 my $pics = draw_pie($r, $file);
525 for my $pic (@$pics) {
526 print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/>$br4";
531 # Time for a bar chart
532 if ($r->{chart_bar}) {
533 my $pics = draw_bars($r, $file);
534 for my $pic (@$pics) {
535 print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/>$br4";
540 # Time for a bar chart
541 if ($r->{chart_line}) {
542 my $pics = draw_lines($r, $file);
543 for my $pic (@$pics) {
544 print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/>$br4";
549 print $index '</body></html>';
558 my $data = $r->{data};
560 my @groups = @{ $r->{group_by_list} };
562 my @values = (0 .. (scalar(@{$r->{column_labels}}) - 1));
563 delete @values[@groups];
565 #my $logo = $doc->findvalue('/reporter/setup/files/chart_logo');
568 for my $vcol (@values) {
569 next unless (defined $vcol);
571 my @pic_data = ([],[]);
572 for my $row (@$data) {
573 next if (!defined($$row[$vcol]) || $$row[$vcol] == 0);
574 my $val = $$row[$vcol];
575 push @{$pic_data[0]}, join(" -- ", @$row[@groups])." ($val)";
576 push @{$pic_data[1]}, $val;
579 next unless (@{$pic_data[0]});
582 my $split = int(scalar(@{$pic_data[0]}) / $size);
583 my $last = scalar(@{$pic_data[0]}) % $size;
585 for my $sub_graph (0 .. $split) {
587 if ($sub_graph == $split) {
592 for my $set (@pic_data) {
593 push @sub_data, [ splice(@$set,0,$size) ];
596 my $pic = new GD::Graph::pie;
599 label => $r->{column_labels}->[$vcol],
601 legend_placement => 'R',
603 #logo_position => 'TL',
608 my $format = $pic->export_format;
610 open(IMG, ">$file.pie.$vcol.$sub_graph.$format") or die "Cannot write '$file.pie.$vcol.$sub_graph.$format'";
615 $pic->plot(\@sub_data) or die $pic->error;
616 print IMG $pic->gd->$format;
619 warn "Couldn't draw $file.pie.$vcol.$sub_graph.$format : $e";
627 { file => "pie.$vcol.$sub_graph.$format",
628 name => $r->{column_labels}->[$vcol].' (Pie)',
629 } unless ($forgetit);
631 last if ($sub_graph == $split);
642 my $data = $r->{data};
644 #my $logo = $doc->findvalue('/reporter/setup/files/chart_logo');
646 my @groups = @{ $r->{group_by_list} };
649 my @values = (0 .. (scalar(@{$r->{column_labels}}) - 1));
650 splice(@values,$_,1) for (reverse @groups);
654 for my $row (@$data) {
655 push @{$pic_data[0]}, join(' -- ', @$row[@groups]);
665 for my $vcol (@values) {
666 next unless (defined $vcol);
667 $pic_data[$set] ||= [];
670 for my $row (@$data) {
671 my $val = $$row[$vcol] ? $$row[$vcol] : 0;
672 push @{$pic_data[$set]}, $val;
673 $max_y = $val if ($val > $max_y);
674 $trim_candidates{$pos}++ if ($val == 0);
680 my $set_count = scalar(@pic_data) - 1;
681 my @trim_cols = grep { $trim_candidates{$_} == $set_count } keys %trim_candidates;
687 for my $dataset (@pic_data) {
688 splice(@$dataset,$_,1) for (reverse sort @trim_cols);
690 if (grep { $_ } @$dataset) {
691 push @new_data, $dataset;
692 push @use_me, $set_index if ($set_index > 0);
694 push @no_use, $set_index;
700 return [] unless ($new_data[0] && @{$new_data[0]});
702 for my $col (@use_me) {
703 push @leg, $r->{column_labels}->[$values[$col - 1]];
706 my $w = 100 + 10 * scalar(@{$new_data[0]});
707 $w = 400 if ($w < 400);
709 my $h = 10 * (scalar(@new_data) / 2);
713 my $pic = new GD::Graph::bars3d ($w + 250, $h + 500);
716 title => $r->{report}{name},
717 x_labels_vertical => 1,
721 y_max_value => $max_y,
722 legend_placement => 'TR',
725 #logo_position => 'R',
730 $pic->set_legend(@leg);
732 my $format = $pic->export_format;
734 open(IMG, ">$file.bar.$format") or die "Cannot write '$file.bar.$format'";
738 $pic->plot(\@new_data) or die $pic->error;
739 print IMG $pic->gd->$format;
742 warn "Couldn't draw $file.bar.$format : $e";
747 return [{ file => "bar.$format",
748 name => $r->{report}{name}.' (Bar)',
756 my $data = $r->{data};
758 #my $logo = $doc->findvalue('/reporter/setup/files/chart_logo');
760 my @groups = @{ $r->{group_by_list} };
762 my @values = (0 .. (scalar(@{$r->{column_labels}}) - 1));
763 splice(@values,$_,1) for (reverse @groups);
767 for my $row (@$data) {
768 push @{$pic_data[0]}, join(' -- ', @$row[@groups]);
776 for my $vcol (@values) {
777 next unless (defined $vcol);
778 $pic_data[$set] ||= [];
781 for my $row (@$data) {
782 my $val = $$row[$vcol] ? $$row[$vcol] : 0;
783 push @{$pic_data[$set]}, $val;
784 $max_y = $val if ($val > $max_y);
789 my $set_count = scalar(@pic_data) - 1;
795 for my $dataset (@pic_data) {
797 if (grep { $_ } @$dataset) {
798 push @new_data, $dataset;
799 push @use_me, $set_index if ($set_index > 0);
801 push @no_use, $set_index;
807 return [] unless ($new_data[0] && @{$new_data[0]});
809 for my $col (@use_me) {
810 push @leg, $r->{column_labels}->[$values[$col - 1]];
813 my $w = 100 + 10 * scalar(@{$new_data[0]});
814 $w = 400 if ($w < 400);
816 my $h = 10 * (scalar(@new_data) / 2);
820 my $pic = new GD::Graph::lines3d ($w + 250, $h + 500);
823 title => $r->{report}{name},
824 x_labels_vertical => 1,
827 y_max_value => $max_y,
828 legend_placement => 'TR',
831 #logo_position => 'R',
836 $pic->set_legend(@leg);
838 my $format = $pic->export_format;
840 open(IMG, ">$file.line.$format") or die "Cannot write '$file.line.$format'";
844 $pic->plot(\@new_data) or die $pic->error;
845 print IMG $pic->gd->$format;
848 warn "Couldn't draw $file.line.$format : $e";
853 return [{ file => "line.$format",
854 name => $r->{report}{name}.' (Bar)',
862 my $pivot_label = shift;
863 my $pivot_data = shift;
865 $default = 0 unless (defined $default);
867 my $data = $$blob{data};
868 my $cols = $$blob{columns};
870 my @keep_labels = @$cols;
871 splice(@keep_labels, $_ - 1, 1) for (reverse sort ($pivot_label, $pivot_data));
873 my @keep_cols = (0 .. @$cols - 1);
874 splice(@keep_cols, $_ - 1, 1) for (reverse sort ($pivot_label, $pivot_data));
876 my @gb = ( 0 .. @keep_cols - 1);
878 #first, find the unique list of pivot values
880 for my $row (@$data) {
881 $tmp{ $$row[$pivot_label - 1] } = 1;
883 my @new_cols = sort keys %tmp;
885 tie my %split_data, 'Tie::IxHash';
886 for my $row (@$data) {
888 my $row_fp = ''. join('', map { defined($$row[$_]) ? $$row[$_] : '' } @keep_cols);
889 $split_data{$row_fp} ||= [];
891 push @{ $split_data{$row_fp} }, $row;
895 #now loop over the data, building a new result set
896 tie my %new_data, 'Tie::IxHash';
898 for my $fp ( keys %split_data ) {
902 for my $col (@keep_cols) {
903 push @{ $new_data{$fp} }, $split_data{$fp}[0][$col];
906 for my $col (@new_cols) {
908 my ($datum) = map { $_->[$pivot_data - 1] } grep { $_->[$pivot_label - 1] eq $col } @{ $split_data{$fp} };
910 push @{ $new_data{$fp} }, $datum;
914 push @keep_labels, @new_cols;
916 return { columns => \@keep_labels, data => [ values %new_data ], group_by_list => \@gb };