10 use DateTime::Format::ISO8601;
13 use Excel::Writer::XLSX;
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 ($config, $sleep_interval, $lockfile, $daemon) = ('SYSCONFDIR/opensrf_core.xml', 10, '/tmp/reporter-LOCK');
35 my $opt_max_rows_for_charts;
36 my $opt_statement_timeout;
37 my $opt_resultset_limit;
41 "sleep=i" => \$sleep_interval,
42 "concurrency=i" => \$opt_count,
43 "max-rows-for-charts=i" => \$opt_max_rows_for_charts,
44 "resultset-limit=i" => \$opt_resultset_limit,
45 "statement-timeout=i" => \$opt_statement_timeout,
46 "bootstrap|boostrap=s" => \$config,
47 "lockfile=s" => \$lockfile,
51 die "I seem to be running already. If not, remove $lockfile and try again\n";
54 OpenSRF::System->bootstrap_client( config_file => $config );
56 my (%data_db, %state_db);
58 my $sc = OpenSRF::Utils::SettingsClient->new;
60 $data_db{db_driver} = $sc->config_value( reporter => setup => database => 'driver' );
61 $data_db{db_host} = $sc->config_value( reporter => setup => database => 'host' );
62 $data_db{db_port} = $sc->config_value( reporter => setup => database => 'port' );
63 $data_db{db_name} = $sc->config_value( reporter => setup => database => 'db' );
64 if (!$data_db{db_name}) {
65 $data_db{db_name} = $sc->config_value( reporter => setup => database => 'name' );
66 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};
68 $data_db{db_user} = $sc->config_value( reporter => setup => database => 'user' );
69 $data_db{db_pw} = $sc->config_value( reporter => setup => database => 'pw' );
70 $data_db{db_app} = $sc->config_value( reporter => setup => database => 'application_name' );
74 # Fetch the optional state database connection info
75 $state_db{db_driver} = $sc->config_value( reporter => setup => state_store => 'driver' ) || $data_db{db_driver};
76 $state_db{db_host} = $sc->config_value( reporter => setup => state_store => 'host' ) || $data_db{db_host};
77 $state_db{db_port} = $sc->config_value( reporter => setup => state_store => 'port' ) || $data_db{db_port};
78 $state_db{db_name} = $sc->config_value( reporter => setup => state_store => 'db' );
79 if (!$state_db{db_name}) {
80 $state_db{db_name} = $sc->config_value( reporter => setup => state_store => 'name' ) || $data_db{db_name};
82 $state_db{db_user} = $sc->config_value( reporter => setup => state_store => 'user' ) || $data_db{db_user};
83 $state_db{db_pw} = $sc->config_value( reporter => setup => state_store => 'pw' ) || $data_db{db_pw};
84 $state_db{db_app} = $sc->config_value( reporter => setup => state_store => 'application_name' )
88 die "Unable to retrieve database connection information from the settings server"
89 unless ($state_db{db_driver} && $state_db{db_host} && $state_db{db_port} && $state_db{db_name} && $state_db{db_user} &&
90 $data_db{db_driver} && $data_db{db_host} && $data_db{db_port} && $data_db{db_name} && $data_db{db_user});
92 my $email_server = $sc->config_value( email_notify => 'smtp_server' );
93 my $email_sender = $sc->config_value( email_notify => 'sender_address' );
94 my $success_template = $sc->config_value( reporter => setup => files => 'success_template' );
95 my $fail_template = $sc->config_value( reporter => setup => files => 'fail_template' );
96 my $output_base = $sc->config_value( reporter => setup => files => 'output_base' );
97 my $base_uri = $sc->config_value( reporter => setup => 'base_uri' );
99 my $state_dsn = "dbi:" . $state_db{db_driver} . ":dbname=" . $state_db{db_name} .';host=' . $state_db{db_host} . ';port=' . $state_db{db_port};
100 $state_dsn .= ";application_name='$state_db{db_app}'" if $state_db{db_app};
101 my $data_dsn = "dbi:" . $data_db{db_driver} . ":dbname=" . $data_db{db_name} .';host=' . $data_db{db_host} . ';port=' . $data_db{db_port};
102 $data_dsn .= ";application_name='$data_db{db_app}'" if $data_db{db_app};
104 my $count = $opt_count //
105 $sc->config_value( reporter => setup => 'parallel' ) //
107 $count = 1 unless $count =~ /^\d+$/ && $count > 0;
108 my $statement_timeout = $opt_statement_timeout //
109 $sc->config_value( reporter => setup => 'statement_timeout' ) //
111 $statement_timeout = 60 unless $statement_timeout =~ /^\d+$/;
112 my $max_rows_for_charts = $opt_max_rows_for_charts //
113 $sc->config_value( reporter => setup => 'max_rows_for_charts' ) //
115 $max_rows_for_charts = 1000 unless $max_rows_for_charts =~ /^\d+$/;
116 my $resultset_limit = $opt_resultset_limit //
117 $sc->config_value( reporter => setup => 'resultset_limit' ) //
119 $resultset_limit = 0 unless $resultset_limit =~ /^\d+$/; # 0 means no limit
121 # What follows is an emperically-derived magic number; if
122 # the row count is larger than this, the table-sorting JavaScript
123 # won't be loaded to excessive churn when viewing HTML reports
124 # in the staff client or web browser.
125 my $sortable_limit = 10000;
127 my ($dbh,$running,$sth,@reports,$run, $current_time);
130 daemonize("Clark Kent, waiting for trouble");
131 open(F, ">$lockfile") or die "Cannot write lockfile '$lockfile'";
144 pg_expand_array => 0,
150 $current_time = DateTime->from_epoch( epoch => time() )->strftime('%FT%T%z');
152 # make sure we're not already running $count reports
153 ($running) = $dbh->selectrow_array(<<SQL);
155 FROM reporter.schedule
156 WHERE start_time IS NOT NULL AND complete_time IS NULL;
159 if ($count <= $running) {
163 POSIX::waitpid( -1, POSIX::WNOHANG );
164 sleep $sleep_interval;
167 print "Already running maximum ($running) concurrent reports\n";
171 # if we have some open slots then generate the sql
172 $run = $count - $running;
174 $sth = $dbh->prepare(<<SQL);
176 FROM reporter.schedule
177 WHERE start_time IS NULL AND run_time < NOW()
185 while (my $r = $sth->fetchrow_hashref) {
186 my $s3 = $dbh->selectrow_hashref(<<" SQL", {}, $r->{report});
187 SELECT * FROM reporter.report WHERE id = ?;
190 my $s2 = $dbh->selectrow_hashref(<<" SQL", {}, $s3->{template});
191 SELECT * FROM reporter.template WHERE id = ?;
194 $s3->{template} = $s2;
197 my $b = OpenILS::Reporter::SQLBuilder->new;
198 my $report_data = OpenSRF::Utils::JSON->JSON2perl( $r->{report}->{data} );
199 $b->register_params( $report_data );
201 $r->{resultset} = $b->parse_report( OpenSRF::Utils::JSON->JSON2perl( $r->{report}->{template}->{data} ) );
202 $r->{resultset}->set_do_rollup($report_data->{__do_rollup}) if $report_data->{__do_rollup};
203 $r->{resultset}->set_pivot_data($report_data->{__pivot_data}) if $report_data->{__pivot_data};
204 $r->{resultset}->set_pivot_label($report_data->{__pivot_label}) if $report_data->{__pivot_label};
205 $r->{resultset}->set_pivot_default($report_data->{__pivot_default}) if $report_data->{__pivot_default};
206 $r->{resultset}->relative_time($r->{run_time});
207 $r->{resultset}->resultset_limit($resultset_limit) if $resultset_limit;
215 # Now we spawn the report runners
217 for my $r ( @reports ) {
218 next if (safe_fork());
220 # This is the child (runner) process;
221 daemonize("Clark Kent reporting: $r->{report}->{name}");
223 my $state_dbh = DBI->connect(
228 pg_expand_array => 0,
234 my $data_dbh = DBI->connect(
239 pg_expand_array => 0,
244 $data_dbh->do('SET statement_timeout = ?', {}, ($statement_timeout * 60 * 1000));
247 $state_dbh->do(<<' SQL',{}, $r->{id});
248 UPDATE reporter.schedule
249 SET start_time = now()
253 $logger->debug('Report SQL: ' . $r->{resultset}->toSQL);
254 $sth = $data_dbh->prepare($r->{resultset}->toSQL);
257 $r->{data} = $sth->fetchall_arrayref;
259 $r->{column_labels} = [$r->{resultset}->column_label_list];
261 if ($r->{resultset}->pivot_data && $r->{resultset}->pivot_label) {
262 my @labels = $r->{resultset}->column_label_list;
263 my $newdata = pivot_data(
264 { columns => $r->{column_labels}, data => $r->{data}},
265 $r->{resultset}->pivot_label,
266 $r->{resultset}->pivot_data,
267 $r->{resultset}->pivot_default
270 $r->{column_labels} = $newdata->{columns};
271 $r->{data} = $newdata->{data};
272 $r->{group_by_list} = $newdata->{group_by_list};
274 $r->{group_by_list} = [$r->{resultset}->group_by_list(0)];
277 my $s2 = $r->{report}->{template}->{id};
278 my $s3 = $r->{report}->{id};
279 my $output = $r->{id};
282 mkdir("$output_base/$s2");
283 mkdir("$output_base/$s2/$s3");
284 mkdir("$output_base/$s2/$s3/$output");
286 my $output_dir = "$output_base/$s2/$s3/$output";
288 if ( $r->{csv_format} ) {
289 build_csv("$output_dir/report-data.csv", $r);
292 if ( $r->{excel_format} ) {
293 build_excel("$output_dir/report-data.xlsx", $r);
296 build_html("$output_dir/report-data.html", $r);
298 $state_dbh->begin_work;
300 if ($r->{report}->{recur} ) {
302 INSERT INTO reporter.schedule (
314 VALUES ( ?, ?, ?, ?::TIMESTAMPTZ + ?, ?, ?, ?, ?, ?, ?, ? );
317 my $prevP = $state_dbh->{PrintError};
318 $state_dbh->{PrintError} = 0;
326 $r->{report}->{recurrence},
335 # Ignore duplicate key errors on reporter.schedule (err 7 is a fatal query error). Just look for the constraint name in the message to avoid l10n issues.
336 warn($state_dbh->errstr()) unless $state_dbh->err() == 7 && $state_dbh->errstr() =~ m/rpt_sched_recurrence_once_idx/;
338 $state_dbh->{PrintError} = $prevP;
341 $state_dbh->do(<<' SQL',{}, $r->{id});
342 UPDATE reporter.schedule
343 SET complete_time = now()
349 my $new_r = $state_dbh->selectrow_hashref(<<" SQL", {}, $r->{id});
350 SELECT * FROM reporter.schedule WHERE id = ?;
353 $r->{start_time} = $new_r->{start_time};
354 $r->{complete_time} = $new_r->{complete_time};
362 $r->{error_text} = ''.$e;
363 if (!$state_dbh->{AutoCommit}) {
364 $state_dbh->rollback;
366 $state_dbh->do(<<' SQL',{}, $e, $r->{id});
367 UPDATE reporter.schedule
369 complete_time = now(),
374 my $new_r = $state_dbh->selectrow_hashref(<<" SQL", {}, $r->{id});
375 SELECT * FROM reporter.schedule WHERE id = ?;
378 $r->{error_text} = $new_r->{error_text};
379 $r->{complete_time} = $new_r->{complete_time};
387 $state_dbh->disconnect;
388 $data_dbh->disconnect;
390 exit; # leave the child
395 POSIX::waitpid( -1, POSIX::WNOHANG );
396 sleep $sleep_interval;
400 #-------------------------------------------------------------------
404 open F, $success_template or die "Cannot read '$success_template'";
405 my $tmpl = join('',<F>);
408 my $url = $base_uri . '/' .
409 $r->{report}->{template}->{id} . '/' .
410 $r->{report}->{id} . '/' .
411 $r->{id} . '/report-data.html';
413 $tmpl =~ s/{TO}/$r->{email}/smog;
414 $tmpl =~ s/{FROM}/$email_sender/smog;
415 $tmpl =~ s/{REPLY_TO}/$email_sender/smog;
416 $tmpl =~ s/{REPORT_NAME}/$r->{report}->{name} -- $r->{report}->{template}->{name}/smog;
417 $tmpl =~ s/{RUN_TIME}/$r->{run_time}/smog;
418 $tmpl =~ s/{COMPLETE_TIME}/$r->{complete_time}/smog;
419 $tmpl =~ s/{OUTPUT_URL}/$url/smog;
421 my $tdata = OpenSRF::Utils::JSON->JSON2perl( $r->{report}->{template}->{data} );
422 if ($$tdata{version} >= 4) {
423 $tmpl =~ s/{EXTERNAL_URL}/$$tdata{doc_url}/smog;
426 my $sender = Email::Send->new({mailer => 'SMTP'});
427 $sender->mailer_args([Host => $email_server]);
428 $sender->send($tmpl);
433 open F, $fail_template or die "Cannot read '$fail_template'";
434 my $tmpl = join('',<F>);
437 my $sql = $r->{resultset}->toSQL;
439 $tmpl =~ s/{TO}/$r->{email}/smog;
440 $tmpl =~ s/{FROM}/$email_sender/smog;
441 $tmpl =~ s/{REPLY_TO}/$email_sender/smog;
442 $tmpl =~ s/{REPORT_NAME}/$r->{report}->{name} -- $r->{report}->{template}->{name}/smog;
443 $tmpl =~ s/{RUN_TIME}/$r->{run_time}/smog;
444 $tmpl =~ s/{ERROR_TEXT}/$r->{error_text}/smog;
445 $tmpl =~ s/{SQL}/$sql/smog;
447 my $tdata = OpenSRF::Utils::JSON->JSON2perl( $r->{report}->{template}->{data} );
448 if ($$tdata{version} >= 4) {
449 $tmpl =~ s/{EXTERNAL_URL}/$$tdata{doc_url}/smog;
452 my $sender = Email::Send->new({mailer => 'SMTP'});
453 $sender->mailer_args([Host => $email_server]);
454 $sender->send($tmpl);
461 my $csv = Text::CSV_XS->new({ always_quote => 1, eol => "\015\012" });
463 return unless ($csv);
465 my $f = new FileHandle (">$file") or die "Cannot write to '$file'";
467 $csv->print($f, $r->{column_labels});
468 $csv->print($f, $_) for (@{$r->{data}});
475 my $xls = Excel::Writer::XLSX->new($file);
477 my $sheetname = substr($r->{report}->{name},0,30);
478 $sheetname =~ s/\W/_/gos;
480 my $sheet = $xls->add_worksheet($sheetname);
481 # don't try to write formulas, just write anything that starts with = as a text cell
482 $sheet->add_write_handler(qr/^=/, sub { return shift->write_string(@_); } );
484 $sheet->write_row('A1', $r->{column_labels});
486 $sheet->write_col('A2', $r->{data});
495 my $index = new FileHandle (">$file") or die "Cannot write to '$file'";
497 my $tdata = OpenSRF::Utils::JSON->JSON2perl( $r->{report}->{template}->{data} );
500 print $index <<" HEADER";
503 <meta charset='utf-8'>
504 <title>$$r{report}{name}</title>
506 table { border-collapse: collapse; }
507 th { background-color: lightgray; }
508 td,th { border: solid black 1px; }
509 * { font-family: sans-serif; font-size: 10px; }
510 .dim { color: lightblue; }
515 <h2><u>$$r{report}{name}</u></h2>
516 $$r{report}{description}<br/>
519 if ($$tdata{version} >= 4 and $$tdata{doc_url}) {
520 print $index "<a target='_blank' href='$$tdata{doc_url}'>External template documentation</a><br/>";
523 print $index "<br/><br/>";
527 my $br4 = '<br/>' x 4;
528 # add a link to the raw output html
529 push @links, "<a href='report-data.html.raw.html'>Tabular Output</a>" if ($r->{html_format});
531 # add a link to the CSV output
532 push @links, "<a href='report-data.xlsx'>Excel Output</a>" if ($r->{excel_format});
534 # add a link to the CSV output
535 push @links, "<a href='report-data.csv'>CSV Output</a>" if ($r->{csv_format});
538 push @links, "<a class='dim' href='report-data.html.debug.html'>Debugging Info</a>";
540 my $debug = new FileHandle (">$file.debug.html") or die "Cannot write to '$file.debug.html'";
541 print $debug "<html><head><meta charset='utf-8'><title>DEBUG: $$r{report}{name}</title></head><body>";
544 if ($$tdata{version} >= 4 and $$tdata{doc_url}) {
545 print $debug "<b><a target='_blank' href='$$tdata{doc_url}'>External template documentation</a></b><br/><a href='report-data.html'>Back to output index</a><hr/>";
548 print $debug '<h1>Generated SQL</h1><pre>' . $r->{resultset}->toSQL() . "</pre><a href='report-data.html'>Back to output index</a><hr/>";
549 print $debug '<h1>Template</h1><pre>' . Dumper( $r->{report}->{template} ) . "</pre><a href='report-data.html'>Back to output index</a><hr/>";
550 print $debug '<h1>Template Data</h1><pre>' . Dumper( $tdata ) . "</pre><a href='report-data.html'>Back to output index</a><hr/>";
551 print $debug '<h1>Report Parameter</h1><pre>' . Dumper( $r->{report} ) . "</pre><a href='report-data.html'>Back to output index</a><hr/>";
552 print $debug '<h1>Report Parameter Data</h1><pre>' . Dumper( $tdata ) . "</pre><a href='report-data.html'>Back to output index</a><hr/>";
553 print $debug '<h1>Report Run Time</h1><pre>' . $r->{resultset}->relative_time . "</pre><a href='report-data.html'>Back to output index</a><hr/>";
554 print $debug '<h1>OpenILS::Reporter::SQLBuilder::ResultSet Object</h1><pre>' . Dumper( $r->{resultset} ) . "</pre><a href='report-data.html'>Back to output index</a>";
557 print $debug '</body></html>';
561 print $index join(' -- ', @links);
562 print $index "$br4</center>";
564 if ($r->{html_format}) {
565 # create the raw output html file
566 my $raw = new FileHandle (">$file.raw.html") or die "Cannot write to '$file.raw.html'";
567 print $raw "<html><head><meta charset='utf-8'><title>$$r{report}{name}</title>";
571 table { border-collapse: collapse; }
572 th { background-color: lightgray; }
573 td,th { border: solid black 1px; }
574 * { font-family: sans-serif; }
576 <link rel="stylesheet" href="/js/sortable/sortable-theme-minimal.css" />
579 print $raw "</head><body><a href='report-data.html'>Back to output index</a><br/><table class='sortable-theme-minimal' data-sortable>";
582 print $raw "<thead><tr><th>".join('</th><th>', @{$r->{column_labels}})."</th></tr></thead>\n<tbody>";
583 print $raw "<tr><td>".join('</td><td>', @$_)."</td></tr>\n" for (@{$r->{data}});
586 print $raw '</tbody></table>';
587 if (@{ $r->{data} } <= $sortable_limit) {
588 print $raw '<script src="/js/sortable/sortable.min.js"></script>';
590 print $raw '</body></html>';
595 # Time for a pie chart
596 if ($r->{chart_pie}) {
597 if (scalar(@{$r->{data}}) > $max_rows_for_charts) {
598 print $index "<strong>Report output has too many rows to make a pie chart</strong>$br4";
600 my $pics = draw_pie($r, $file);
601 for my $pic (@$pics) {
602 print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/>$br4";
608 # Time for a bar chart
609 if ($r->{chart_bar}) {
610 if (scalar(@{$r->{data}}) > $max_rows_for_charts) {
611 print $index "<strong>Report output has too many rows to make a bar chart</strong>$br4";
613 my $pics = draw_bars($r, $file);
614 for my $pic (@$pics) {
615 print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/>$br4";
621 # Time for a bar chart
622 if ($r->{chart_line}) {
623 if (scalar(@{$r->{data}}) > $max_rows_for_charts) {
624 print $index "<strong>Report output has too many rows to make a line chart</strong>$br4";
626 my $pics = draw_lines($r, $file);
627 for my $pic (@$pics) {
628 print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/>$br4";
634 print $index '</body></html>';
643 my $data = $r->{data};
645 my @groups = @{ $r->{group_by_list} };
647 my @values = (0 .. (scalar(@{$r->{column_labels}}) - 1));
648 delete @values[@groups];
650 #my $logo = $doc->findvalue('/reporter/setup/files/chart_logo');
653 for my $vcol (@values) {
654 next unless (defined $vcol);
656 my @pic_data = ([],[]);
657 for my $row (@$data) {
658 next if (!defined($$row[$vcol]) || $$row[$vcol] == 0);
659 my $val = $$row[$vcol];
660 push @{$pic_data[0]}, join(" -- ", @$row[@groups])." ($val)";
661 push @{$pic_data[1]}, $val;
664 next unless (@{$pic_data[0]});
667 my $split = int(scalar(@{$pic_data[0]}) / $size);
668 my $last = scalar(@{$pic_data[0]}) % $size;
670 for my $sub_graph (0 .. $split) {
672 if ($sub_graph == $split) {
677 for my $set (@pic_data) {
678 push @sub_data, [ splice(@$set,0,$size) ];
681 my $pic = new GD::Graph::pie;
684 label => $r->{column_labels}->[$vcol],
686 legend_placement => 'R',
688 #logo_position => 'TL',
693 my $format = $pic->export_format;
695 open(IMG, ">$file.pie.$vcol.$sub_graph.$format") or die "Cannot write '$file.pie.$vcol.$sub_graph.$format'";
700 $pic->plot(\@sub_data) or die $pic->error;
701 print IMG $pic->gd->$format;
704 warn "Couldn't draw $file.pie.$vcol.$sub_graph.$format : $e";
712 { file => "pie.$vcol.$sub_graph.$format",
713 name => $r->{column_labels}->[$vcol].' (Pie)',
714 } unless ($forgetit);
716 last if ($sub_graph == $split);
727 my $data = $r->{data};
729 #my $logo = $doc->findvalue('/reporter/setup/files/chart_logo');
731 my @groups = @{ $r->{group_by_list} };
734 my @values = (0 .. (scalar(@{$r->{column_labels}}) - 1));
735 splice(@values,$_,1) for (reverse @groups);
739 for my $row (@$data) {
740 push @{$pic_data[0]}, join(' -- ', @$row[@groups]);
750 for my $vcol (@values) {
751 next unless (defined $vcol);
752 $pic_data[$set] ||= [];
755 for my $row (@$data) {
756 my $val = $$row[$vcol] ? $$row[$vcol] : 0;
757 push @{$pic_data[$set]}, $val;
758 $max_y = $val if ($val > $max_y);
759 $trim_candidates{$pos}++ if ($val == 0);
765 my $set_count = scalar(@pic_data) - 1;
766 my @trim_cols = grep { $trim_candidates{$_} == $set_count } keys %trim_candidates;
772 for my $dataset (@pic_data) {
773 splice(@$dataset,$_,1) for (reverse sort @trim_cols);
775 if (grep { $_ } @$dataset) {
776 push @new_data, $dataset;
777 push @use_me, $set_index if ($set_index > 0);
779 push @no_use, $set_index;
785 return [] unless ($new_data[0] && @{$new_data[0]});
787 for my $col (@use_me) {
788 push @leg, $r->{column_labels}->[$values[$col - 1]];
791 my $w = 100 + 10 * scalar(@{$new_data[0]});
792 $w = 400 if ($w < 400);
794 my $h = 10 * (scalar(@new_data) / 2);
798 my $pic = new GD::Graph::bars3d ($w + 250, $h + 500);
801 title => $r->{report}{name},
802 x_labels_vertical => 1,
806 y_max_value => $max_y,
807 legend_placement => 'TR',
810 #logo_position => 'R',
815 $pic->set_legend(@leg);
817 my $format = $pic->export_format;
819 open(IMG, ">$file.bar.$format") or die "Cannot write '$file.bar.$format'";
823 $pic->plot(\@new_data) or die $pic->error;
824 print IMG $pic->gd->$format;
827 warn "Couldn't draw $file.bar.$format : $e";
832 return [{ file => "bar.$format",
833 name => $r->{report}{name}.' (Bar)',
841 my $data = $r->{data};
843 #my $logo = $doc->findvalue('/reporter/setup/files/chart_logo');
845 my @groups = @{ $r->{group_by_list} };
847 my @values = (0 .. (scalar(@{$r->{column_labels}}) - 1));
848 splice(@values,$_,1) for (reverse @groups);
852 for my $row (@$data) {
853 push @{$pic_data[0]}, join(' -- ', @$row[@groups]);
861 for my $vcol (@values) {
862 next unless (defined $vcol);
863 $pic_data[$set] ||= [];
866 for my $row (@$data) {
867 my $val = $$row[$vcol] ? $$row[$vcol] : 0;
868 push @{$pic_data[$set]}, $val;
869 $max_y = $val if ($val > $max_y);
874 my $set_count = scalar(@pic_data) - 1;
880 for my $dataset (@pic_data) {
882 if (grep { $_ } @$dataset) {
883 push @new_data, $dataset;
884 push @use_me, $set_index if ($set_index > 0);
886 push @no_use, $set_index;
892 return [] unless ($new_data[0] && @{$new_data[0]});
894 for my $col (@use_me) {
895 push @leg, $r->{column_labels}->[$values[$col - 1]];
898 my $w = 100 + 10 * scalar(@{$new_data[0]});
899 $w = 400 if ($w < 400);
901 my $h = 10 * (scalar(@new_data) / 2);
905 my $pic = new GD::Graph::lines3d ($w + 250, $h + 500);
908 title => $r->{report}{name},
909 x_labels_vertical => 1,
912 y_max_value => $max_y,
913 legend_placement => 'TR',
916 #logo_position => 'R',
921 $pic->set_legend(@leg);
923 my $format = $pic->export_format;
925 open(IMG, ">$file.line.$format") or die "Cannot write '$file.line.$format'";
929 $pic->plot(\@new_data) or die $pic->error;
930 print IMG $pic->gd->$format;
933 warn "Couldn't draw $file.line.$format : $e";
938 return [{ file => "line.$format",
939 name => $r->{report}{name}.' (Bar)',
947 my $pivot_label = shift;
948 my $pivot_data = shift;
950 $default = 0 unless (defined $default);
952 my $data = $$blob{data};
953 my $cols = $$blob{columns};
955 my @keep_labels = @$cols;
956 splice(@keep_labels, $_ - 1, 1) for (reverse sort ($pivot_label, $pivot_data));
958 my @keep_cols = (0 .. @$cols - 1);
959 splice(@keep_cols, $_ - 1, 1) for (reverse sort ($pivot_label, $pivot_data));
961 my @gb = ( 0 .. @keep_cols - 1);
963 #first, find the unique list of pivot values
965 for my $row (@$data) {
966 $tmp{ $$row[$pivot_label - 1] } = 1;
968 my @new_cols = sort keys %tmp;
970 tie my %split_data, 'Tie::IxHash';
971 for my $row (@$data) {
973 my $row_fp = ''. join('', map { defined($$row[$_]) ? $$row[$_] : '' } @keep_cols);
974 $split_data{$row_fp} ||= [];
976 push @{ $split_data{$row_fp} }, $row;
980 #now loop over the data, building a new result set
981 tie my %new_data, 'Tie::IxHash';
983 for my $fp ( keys %split_data ) {
987 for my $col (@keep_cols) {
988 push @{ $new_data{$fp} }, $split_data{$fp}[0][$col];
991 for my $col (@new_cols) {
993 my ($datum) = map { $_->[$pivot_data - 1] } grep { $_->[$pivot_label - 1] eq $col } @{ $split_data{$fp} };
995 push @{ $new_data{$fp} }, $datum;
999 push @keep_labels, @new_cols;
1001 return { columns => \@keep_labels, data => [ values %new_data ], group_by_list => \@gb };