Open-ILS/src/reporter/clark-kent.pl

   1 #!/usr/bin/perl
   2 # vim:ts=4:noet:
   3
   4 use strict;
   5 use DBI;
   6 use FileHandle;
   7 use XML::LibXML;
   8 use Getopt::Long;
   9 use DateTime;
  10 use DateTime::Format::ISO8601;
  11 use Data::Dumper;
  12 use Text::CSV_XS;
  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/;
  18 use OpenSRF::System;
  19 use OpenSRF::AppSession;
  20 use OpenSRF::Utils::SettingsClient;
  21 use OpenILS::Reporter::SQLBuilder;
  22 use POSIX;
  23 use GD::Graph::pie;
  24 use GD::Graph::bars3d;
  25 use GD::Graph::lines3d;
  26 use Tie::IxHash;
  27 use Email::Send;
  28
  29 use open ':utf8';
  30
  31
  32 my ($config, $sleep_interval, $lockfile, $daemon) = ('SYSCONFDIR/opensrf_core.xml', 10, '/tmp/reporter-LOCK');
  33
  34 my $opt_count;
  35 my $opt_max_rows_for_charts;
  36 my $opt_statement_timeout;
  37 my $opt_resultset_limit;
  38
  39 GetOptions(
  40         "daemon"        => \$daemon,
  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,
  48 );
  49
  50 if (-e $lockfile) {
  51         die "I seem to be running already. If not, remove $lockfile and try again\n";
  52 }
  53
  54 OpenSRF::System->bootstrap_client( config_file => $config );
  55
  56 my (%data_db, %state_db);
  57
  58 my $sc = OpenSRF::Utils::SettingsClient->new;
  59
  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};
  67 }
  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
  71
  72
  73 # Fetch the optional state database connection info
  74 $state_db{db_driver} = $sc->config_value( reporter => setup => state_store => 'driver' ) || $data_db{db_driver};
  75 $state_db{db_host}   = $sc->config_value( reporter => setup => state_store => 'host'   ) || $data_db{db_host};
  76 $state_db{db_port}   = $sc->config_value( reporter => setup => state_store => 'port'   ) || $data_db{db_port};
  77 $state_db{db_name}   = $sc->config_value( reporter => setup => state_store => 'db'     );
  78 if (!$state_db{db_name}) {
  79     $state_db{db_name} = $sc->config_value( reporter => setup => state_store => 'name' ) || $data_db{db_name};
  80 }
  81 $state_db{db_user}   = $sc->config_value( reporter => setup => state_store => 'user'   ) || $data_db{db_user};
  82 $state_db{db_pw}     = $sc->config_value( reporter => setup => state_store => 'pw'     ) || $data_db{db_pw};
  83
  84
  85 die "Unable to retrieve database connection information from the settings server"
  86     unless ($state_db{db_driver} && $state_db{db_host} && $state_db{db_port} && $state_db{db_name} && $state_db{db_user} &&
  87         $data_db{db_driver} && $data_db{db_host} && $data_db{db_port} && $data_db{db_name} && $data_db{db_user});
  88
  89 my $email_server     = $sc->config_value( email_notify => 'smtp_server' );
  90 my $email_sender     = $sc->config_value( email_notify => 'sender_address' );
  91 my $success_template = $sc->config_value( reporter => setup => files => 'success_template' );
  92 my $fail_template    = $sc->config_value( reporter => setup => files => 'fail_template' );
  93 my $output_base      = $sc->config_value( reporter => setup => files => 'output_base' );
  94 my $base_uri         = $sc->config_value( reporter => setup => 'base_uri' );
  95
  96 my $state_dsn = "dbi:" . $state_db{db_driver} . ":dbname=" . $state_db{db_name} .';host=' . $state_db{db_host} . ';port=' . $state_db{db_port};
  97 my $data_dsn  = "dbi:" .  $data_db{db_driver} . ":dbname=" .  $data_db{db_name} .';host=' .  $data_db{db_host} . ';port=' .  $data_db{db_port};
  98
  99 my $count               = $opt_count //
 100                           $sc->config_value( reporter => setup => 'parallel' ) //
 101                           1;
 102 $count = 1 unless $count =~ /^\d+$/ && $count > 0;
 103 my $statement_timeout   = $opt_statement_timeout //
 104                           $sc->config_value( reporter => setup => 'statement_timeout' ) //
 105                           60;
 106 $statement_timeout = 60 unless $statement_timeout =~ /^\d+$/;
 107 my $max_rows_for_charts = $opt_max_rows_for_charts //
 108                           $sc->config_value( reporter => setup => 'max_rows_for_charts' ) //
 109                           1000;
 110 $max_rows_for_charts = 1000 unless $max_rows_for_charts =~ /^\d+$/;
 111 my $resultset_limit     = $opt_resultset_limit //
 112                           $sc->config_value( reporter => setup => 'resultset_limit' ) //
 113                           0;
 114 $resultset_limit = 0 unless $resultset_limit =~ /^\d+$/; # 0 means no limit
 115
 116 my ($dbh,$running,$sth,@reports,$run, $current_time);
 117
 118 if ($daemon) {
 119         daemonize("Clark Kent, waiting for trouble");
 120         open(F, ">$lockfile") or die "Cannot write lockfile '$lockfile'";
 121         print F $$;
 122         close F;
 123 }
 124
 125
 126 DAEMON:
 127
 128 $dbh = DBI->connect(
 129         $state_dsn,
 130         $state_db{db_user},
 131         $state_db{db_pw},
 132         { AutoCommit => 1,
 133           pg_expand_array => 0,
 134           pg_enable_utf8 => 1,
 135           RaiseError => 1
 136         }
 137 );
 138
 139 $current_time = DateTime->from_epoch( epoch => time() )->strftime('%FT%T%z');
 140
 141 # make sure we're not already running $count reports
 142 ($running) = $dbh->selectrow_array(<<SQL);
 143 SELECT  count(*)
 144   FROM  reporter.schedule
 145   WHERE start_time IS NOT NULL AND complete_time IS NULL;
 146 SQL
 147
 148 if ($count <= $running) {
 149         if ($daemon) {
 150                 $dbh->disconnect;
 151                 sleep 1;
 152                 POSIX::waitpid( -1, POSIX::WNOHANG );
 153                 sleep $sleep_interval;
 154                 goto DAEMON;
 155         }
 156         print "Already running maximum ($running) concurrent reports\n";
 157         exit 1;
 158 }
 159
 160 # if we have some open slots then generate the sql
 161 $run = $count - $running;
 162
 163 $sth = $dbh->prepare(<<SQL);
 164 SELECT  *
 165   FROM  reporter.schedule
 166   WHERE start_time IS NULL AND run_time < NOW()
 167   ORDER BY run_time
 168   LIMIT $run;
 169 SQL
 170
 171 $sth->execute;
 172
 173 @reports = ();
 174 while (my $r = $sth->fetchrow_hashref) {
 175         my $s3 = $dbh->selectrow_hashref(<<"    SQL", {}, $r->{report});
 176                 SELECT * FROM reporter.report WHERE id = ?;
 177         SQL
 178
 179         my $s2 = $dbh->selectrow_hashref(<<"    SQL", {}, $s3->{template});
 180                 SELECT * FROM reporter.template WHERE id = ?;
 181         SQL
 182
 183         $s3->{template} = $s2;
 184         $r->{report} = $s3;
 185
 186         my $b = OpenILS::Reporter::SQLBuilder->new;
 187         my $report_data = OpenSRF::Utils::JSON->JSON2perl( $r->{report}->{data} );
 188         $b->register_params( $report_data );
 189
 190         $r->{resultset} = $b->parse_report( OpenSRF::Utils::JSON->JSON2perl( $r->{report}->{template}->{data} ) );
 191         $r->{resultset}->set_pivot_data($report_data->{__pivot_data}) if $report_data->{__pivot_data};
 192         $r->{resultset}->set_pivot_label($report_data->{__pivot_label}) if $report_data->{__pivot_label};
 193         $r->{resultset}->set_pivot_default($report_data->{__pivot_default}) if $report_data->{__pivot_default};
 194         $r->{resultset}->relative_time($r->{run_time});
 195         $r->{resultset}->resultset_limit($resultset_limit) if $resultset_limit;
 196         push @reports, $r;
 197 }
 198
 199 $sth->finish;
 200
 201 $dbh->disconnect;
 202
 203 # Now we spawn the report runners
 204
 205 for my $r ( @reports ) {
 206         next if (safe_fork());
 207
 208         # This is the child (runner) process;
 209         daemonize("Clark Kent reporting: $r->{report}->{name}");
 210
 211         my $state_dbh = DBI->connect(
 212                 $state_dsn,
 213                 $state_db{db_user},
 214                 $state_db{db_pw},
 215                 { AutoCommit => 1,
 216                   pg_expand_array => 0,
 217                   pg_enable_utf8 => 1,
 218                   RaiseError => 1
 219                 }
 220         );
 221
 222         my $data_dbh = DBI->connect(
 223                 $data_dsn,
 224                 $data_db{db_user},
 225                 $data_db{db_pw},
 226                 { AutoCommit => 1,
 227                   pg_expand_array => 0,
 228                   pg_enable_utf8 => 1,
 229                   RaiseError => 1
 230                 }
 231         );
 232         $data_dbh->do('SET statement_timeout = ?', {}, ($statement_timeout * 60 * 1000));
 233
 234         try {
 235                 $state_dbh->do(<<'              SQL',{}, $r->{id});
 236                         UPDATE  reporter.schedule
 237                           SET   start_time = now()
 238                           WHERE id = ?;
 239                 SQL
 240
 241             $logger->debug('Report SQL: ' . $r->{resultset}->toSQL);
 242                 $sth = $data_dbh->prepare($r->{resultset}->toSQL);
 243
 244                 $sth->execute;
 245                 $r->{data} = $sth->fetchall_arrayref;
 246
 247                 $r->{column_labels} = [$r->{resultset}->column_label_list];
 248
 249                 if ($r->{resultset}->pivot_data && $r->{resultset}->pivot_label) {
 250                         my @labels = $r->{resultset}->column_label_list;
 251                         my $newdata = pivot_data(
 252                                 { columns => $r->{column_labels}, data => $r->{data}},
 253                                 $r->{resultset}->pivot_label,
 254                                 $r->{resultset}->pivot_data,
 255                                 $r->{resultset}->pivot_default
 256                         );
 257
 258                         $r->{column_labels} = $newdata->{columns};
 259                         $r->{data} = $newdata->{data};
 260                         $r->{group_by_list} = $newdata->{group_by_list};
 261                 } else {
 262                         $r->{group_by_list} = [$r->{resultset}->group_by_list(0)];
 263                 }
 264
 265                 my $s2 = $r->{report}->{template}->{id};
 266                 my $s3 = $r->{report}->{id};
 267                 my $output = $r->{id};
 268
 269                 mkdir($output_base);
 270                 mkdir("$output_base/$s2");
 271                 mkdir("$output_base/$s2/$s3");
 272                 mkdir("$output_base/$s2/$s3/$output");
 273
 274                 my $output_dir = "$output_base/$s2/$s3/$output";
 275
 276                 if ( $r->{csv_format} ) {
 277                         build_csv("$output_dir/report-data.csv", $r);
 278                 }
 279
 280                 if ( $r->{excel_format} ) {
 281                         build_excel("$output_dir/report-data.xlsx", $r);
 282                 }
 283
 284                 build_html("$output_dir/report-data.html", $r);
 285
 286                 $state_dbh->begin_work;
 287
 288                 if ($r->{report}->{recur} ) {
 289                         my $sql = <<'                   SQL';
 290                                 INSERT INTO reporter.schedule (
 291                                                 report,
 292                                                 folder,
 293                                                 runner,
 294                                                 run_time,
 295                                                 email,
 296                                                 csv_format,
 297                                                 excel_format,
 298                                                 html_format,
 299                                                 chart_pie,
 300                                                 chart_bar,
 301                                                 chart_line )
 302                                         VALUES ( ?, ?, ?, ?::TIMESTAMPTZ + ?, ?, ?, ?, ?, ?, ?, ? );
 303                         SQL
 304
 305                         $state_dbh->do(
 306                                 $sql,
 307                                 {},
 308                                 $r->{report}->{id},
 309                                 $r->{folder},
 310                                 $r->{runner},
 311                                 $r->{run_time},
 312                                 $r->{report}->{recurrence},
 313                                 $r->{email},
 314                                 $r->{csv_format},
 315                                 $r->{excel_format},
 316                                 $r->{html_format},
 317                                 $r->{chart_pie},
 318                                 $r->{chart_bar},
 319                                 $r->{chart_line},
 320                         );
 321                 }
 322
 323                 $state_dbh->do(<<'              SQL',{}, $r->{id});
 324                         UPDATE  reporter.schedule
 325                           SET   complete_time = now()
 326                           WHERE id = ?;
 327                 SQL
 328
 329                 $state_dbh->commit;
 330
 331                 my $new_r = $state_dbh->selectrow_hashref(<<"           SQL", {}, $r->{id});
 332                         SELECT * FROM reporter.schedule WHERE id = ?;
 333                 SQL
 334
 335                 $r->{start_time}    = $new_r->{start_time};
 336                 $r->{complete_time} = $new_r->{complete_time};
 337
 338                 if ($r->{email}) {
 339                         send_success($r);
 340                 }
 341
 342         } otherwise {
 343                 my $e = shift;
 344                 $r->{error_text} = ''.$e;
 345                 if (!$state_dbh->{AutoCommit}) {
 346                         $state_dbh->rollback;
 347                 }
 348                 $state_dbh->do(<<'              SQL',{}, $e, $r->{id});
 349                         UPDATE  reporter.schedule
 350                           SET   error_text = ?,
 351                                 complete_time = now(),
 352                                 error_code = 1
 353                           WHERE id = ?;
 354                 SQL
 355
 356                 my $new_r = $state_dbh->selectrow_hashref(<<"           SQL", {}, $r->{id});
 357                         SELECT * FROM reporter.schedule WHERE id = ?;
 358                 SQL
 359
 360                 $r->{error_text}    = $new_r->{error_text};
 361                 $r->{complete_time} = $new_r->{complete_time};
 362
 363                 if ($r->{email}) {
 364                         send_fail($r);
 365                 }
 366
 367         };
 368
 369         $state_dbh->disconnect;
 370         $data_dbh->disconnect;
 371
 372         exit; # leave the child
 373 }
 374
 375 if ($daemon) {
 376         sleep 1;
 377         POSIX::waitpid( -1, POSIX::WNOHANG );
 378         sleep $sleep_interval;
 379         goto DAEMON;
 380 }
 381
 382 #-------------------------------------------------------------------
 383
 384 sub send_success {
 385         my $r = shift;
 386         open F, $success_template or die "Cannot read '$success_template'";
 387         my $tmpl = join('',<F>);
 388         close F;
 389
 390         my $url = $base_uri . '/' .
 391                 $r->{report}->{template}->{id} . '/' .
 392                 $r->{report}->{id} . '/' .
 393                 $r->{id} . '/report-data.html';
 394
 395         $tmpl =~ s/{TO}/$r->{email}/smog;
 396         $tmpl =~ s/{FROM}/$email_sender/smog;
 397         $tmpl =~ s/{REPLY_TO}/$email_sender/smog;
 398         $tmpl =~ s/{REPORT_NAME}/$r->{report}->{name} -- $r->{report}->{template}->{name}/smog;
 399         $tmpl =~ s/{RUN_TIME}/$r->{run_time}/smog;
 400         $tmpl =~ s/{COMPLETE_TIME}/$r->{complete_time}/smog;
 401         $tmpl =~ s/{OUTPUT_URL}/$url/smog;
 402
 403         my $tdata = OpenSRF::Utils::JSON->JSON2perl( $r->{report}->{template}->{data} );
 404         if ($$tdata{version} >= 4) {
 405                 $tmpl =~ s/{EXTERNAL_URL}/$$tdata{doc_url}/smog;
 406         }
 407
 408         my $sender = Email::Send->new({mailer => 'SMTP'});
 409         $sender->mailer_args([Host => $email_server]);
 410         $sender->send($tmpl);
 411 }
 412
 413 sub send_fail {
 414         my $r = shift;
 415         open F, $fail_template or die "Cannot read '$fail_template'";
 416         my $tmpl = join('',<F>);
 417         close F;
 418
 419         my $sql = $r->{resultset}->toSQL;
 420
 421         $tmpl =~ s/{TO}/$r->{email}/smog;
 422         $tmpl =~ s/{FROM}/$email_sender/smog;
 423         $tmpl =~ s/{REPLY_TO}/$email_sender/smog;
 424         $tmpl =~ s/{REPORT_NAME}/$r->{report}->{name} -- $r->{report}->{template}->{name}/smog;
 425         $tmpl =~ s/{RUN_TIME}/$r->{run_time}/smog;
 426         $tmpl =~ s/{ERROR_TEXT}/$r->{error_text}/smog;
 427         $tmpl =~ s/{SQL}/$sql/smog;
 428
 429         my $tdata = OpenSRF::Utils::JSON->JSON2perl( $r->{report}->{template}->{data} );
 430         if ($$tdata{version} >= 4) {
 431                 $tmpl =~ s/{EXTERNAL_URL}/$$tdata{doc_url}/smog;
 432         }
 433
 434         my $sender = Email::Send->new({mailer => 'SMTP'});
 435         $sender->mailer_args([Host => $email_server]);
 436         $sender->send($tmpl);
 437 }
 438
 439 sub build_csv {
 440         my $file = shift;
 441         my $r = shift;
 442
 443         my $csv = Text::CSV_XS->new({ always_quote => 1, eol => "\015\012" });
 444
 445         return unless ($csv);
 446
 447         my $f = new FileHandle (">$file") or die "Cannot write to '$file'";
 448
 449         $csv->print($f, $r->{column_labels});
 450         $csv->print($f, $_) for (@{$r->{data}});
 451
 452         $f->close;
 453 }
 454 sub build_excel {
 455         my $file = shift;
 456         my $r = shift;
 457         my $xls = Excel::Writer::XLSX->new($file);
 458
 459         my $sheetname = substr($r->{report}->{name},0,30);
 460         $sheetname =~ s/\W/_/gos;
 461
 462         my $sheet = $xls->add_worksheet($sheetname);
 463         # don't try to write formulas, just write anything that starts with = as a text cell
 464         $sheet->add_write_handler(qr/^=/, sub { return shift->write_string(@_); } );
 465
 466         $sheet->write_row('A1', $r->{column_labels});
 467
 468         $sheet->write_col('A2', $r->{data});
 469
 470         $xls->close;
 471 }
 472
 473 sub build_html {
 474         my $file = shift;
 475         my $r = shift;
 476
 477         my $index = new FileHandle (">$file") or die "Cannot write to '$file'";
 478
 479         my $tdata = OpenSRF::Utils::JSON->JSON2perl( $r->{report}->{template}->{data} );
 480
 481         # index header
 482         print $index <<"        HEADER";
 483 <html>
 484         <head>
 485                 <meta charset='utf-8'>
 486                 <title>$$r{report}{name}</title>
 487                 <style>
 488                         table { border-collapse: collapse; }
 489                         th { background-color: lightgray; }
 490                         td,th { border: solid black 1px; }
 491                         * { font-family: sans-serif; font-size: 10px; }
 492                         .dim { color: lightblue; }
 493                 </style>
 494         </head>
 495         <body>
 496                 <center>
 497                 <h2><u>$$r{report}{name}</u></h2>
 498                 $$r{report}{description}<br/>
 499         HEADER
 500
 501         if ($$tdata{version} >= 4 and $$tdata{doc_url}) {
 502                 print $index "<a target='_blank' href='$$tdata{doc_url}'>External template documentation</a><br/>";
 503         }
 504
 505         print $index "<br/><br/>";
 506
 507         my @links;
 508
 509     my $br4 = '<br/>' x 4;
 510         # add a link to the raw output html
 511         push @links, "<a href='report-data.html.raw.html'>Tabular Output</a>" if ($r->{html_format});
 512
 513         # add a link to the CSV output
 514         push @links, "<a href='report-data.xlsx'>Excel Output</a>" if ($r->{excel_format});
 515
 516         # add a link to the CSV output
 517         push @links, "<a href='report-data.csv'>CSV Output</a>" if ($r->{csv_format});
 518
 519         # debugging output
 520         push @links, "<a class='dim' href='report-data.html.debug.html'>Debugging Info</a>";
 521
 522         my $debug = new FileHandle (">$file.debug.html") or die "Cannot write to '$file.debug.html'";
 523         print $debug "<html><head><meta charset='utf-8'><title>DEBUG: $$r{report}{name}</title></head><body>";
 524
 525         {       no warnings;
 526                 if ($$tdata{version} >= 4 and $$tdata{doc_url}) {
 527                         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/>";
 528                 }
 529
 530                 print $debug '<h1>Generated SQL</h1><pre>' . $r->{resultset}->toSQL() . "</pre><a href='report-data.html'>Back to output index</a><hr/>";
 531                 print $debug '<h1>Template</h1><pre>' . Dumper( $r->{report}->{template} ) . "</pre><a href='report-data.html'>Back to output index</a><hr/>";
 532                 print $debug '<h1>Template Data</h1><pre>' . Dumper( $tdata ) . "</pre><a href='report-data.html'>Back to output index</a><hr/>";
 533                 print $debug '<h1>Report Parameter</h1><pre>' . Dumper( $r->{report} ) . "</pre><a href='report-data.html'>Back to output index</a><hr/>";
 534                 print $debug '<h1>Report Parameter Data</h1><pre>' . Dumper( $tdata ) . "</pre><a href='report-data.html'>Back to output index</a><hr/>";
 535                 print $debug '<h1>Report Run Time</h1><pre>' . $r->{resultset}->relative_time . "</pre><a href='report-data.html'>Back to output index</a><hr/>";
 536                 print $debug '<h1>OpenILS::Reporter::SQLBuilder::ResultSet Object</h1><pre>' . Dumper( $r->{resultset} ) . "</pre><a href='report-data.html'>Back to output index</a>";
 537         }
 538
 539         print $debug '</body></html>';
 540
 541         $debug->close;
 542
 543         print $index join(' -- ', @links);
 544         print $index "$br4</center>";
 545
 546         if ($r->{html_format}) {
 547                 # create the raw output html file
 548                 my $raw = new FileHandle (">$file.raw.html") or die "Cannot write to '$file.raw.html'";
 549                 print $raw "<html><head><meta charset='utf-8'><title>$$r{report}{name}</title>";
 550
 551                 print $raw <<'          CSS';
 552                         <style>
 553                                 table { border-collapse: collapse; }
 554                                 th { background-color: lightgray; }
 555                                 td,th { border: solid black 1px; }
 556                                 * { font-family: sans-serif; font-size: 10px; }
 557                         </style>
 558                 CSS
 559
 560                 print $raw "</head><body><table>";
 561
 562                 {       no warnings;
 563                         print $raw "<tr><th>".join('</th><th>',@{$r->{column_labels}}).'</th></tr>';
 564                         print $raw "<tr><td>".join('</td><td>',@$_                   ).'</td></tr>' for (@{$r->{data}});
 565                 }
 566
 567                 print $raw '</table></body></html>';
 568
 569                 $raw->close;
 570         }
 571
 572         # Time for a pie chart
 573         if ($r->{chart_pie}) {
 574                 if (scalar(@{$r->{data}}) > $max_rows_for_charts) {
 575                         print $index "<strong>Report output has too many rows to make a pie chart</strong>$br4";
 576                 } else {
 577                         my $pics = draw_pie($r, $file);
 578                         for my $pic (@$pics) {
 579                                 print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/>$br4";
 580                         }
 581                 }
 582         }
 583
 584         print $index $br4;
 585         # Time for a bar chart
 586         if ($r->{chart_bar}) {
 587                 if (scalar(@{$r->{data}}) > $max_rows_for_charts) {
 588                         print $index "<strong>Report output has too many rows to make a bar chart</strong>$br4";
 589                 } else {
 590                         my $pics = draw_bars($r, $file);
 591                         for my $pic (@$pics) {
 592                                 print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/>$br4";
 593                         }
 594                 }
 595         }
 596
 597         print $index $br4;
 598         # Time for a bar chart
 599         if ($r->{chart_line}) {
 600                 if (scalar(@{$r->{data}}) > $max_rows_for_charts) {
 601                         print $index "<strong>Report output has too many rows to make a line chart</strong>$br4";
 602                 } else {
 603                         my $pics = draw_lines($r, $file);
 604                         for my $pic (@$pics) {
 605                                 print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/>$br4";
 606                         }
 607             }
 608         }
 609
 610         # and that's it!
 611         print $index '</body></html>';
 612
 613         $index->close;
 614 }
 615
 616 sub draw_pie {
 617         my $r = shift;
 618         my $file = shift;
 619
 620         my $data = $r->{data};
 621
 622         my @groups = @{ $r->{group_by_list} };
 623
 624         my @values = (0 .. (scalar(@{$r->{column_labels}}) - 1));
 625         delete @values[@groups];
 626
 627         #my $logo = $doc->findvalue('/reporter/setup/files/chart_logo');
 628
 629         my @pics;
 630         for my $vcol (@values) {
 631                 next unless (defined $vcol);
 632
 633                 my @pic_data = ([],[]);
 634                 for my $row (@$data) {
 635                         next if (!defined($$row[$vcol]) || $$row[$vcol] == 0);
 636                         my $val = $$row[$vcol];
 637                         push @{$pic_data[0]}, join(" -- ", @$row[@groups])." ($val)";
 638                         push @{$pic_data[1]}, $val;
 639                 }
 640
 641                 next unless (@{$pic_data[0]});
 642
 643                 my $size = 300;
 644                 my $split = int(scalar(@{$pic_data[0]}) / $size);
 645                 my $last = scalar(@{$pic_data[0]}) % $size;
 646
 647                 for my $sub_graph (0 .. $split) {
 648
 649                         if ($sub_graph == $split) {
 650                                 $size = $last;
 651                         }
 652
 653                         my @sub_data;
 654                         for my $set (@pic_data) {
 655                                 push @sub_data, [ splice(@$set,0,$size) ];
 656                         }
 657
 658                         my $pic = new GD::Graph::pie;
 659
 660                         $pic->set(
 661                                 label                   => $r->{column_labels}->[$vcol],
 662                                 start_angle             => 180,
 663                                 legend_placement        => 'R',
 664                                 #logo                   => $logo,
 665                                 #logo_position          => 'TL',
 666                                 #logo_resize            => 0.5,
 667                                 show_values             => 1,
 668                         );
 669
 670                         my $format = $pic->export_format;
 671
 672                         open(IMG, ">$file.pie.$vcol.$sub_graph.$format") or die "Cannot write '$file.pie.$vcol.$sub_graph.$format'";
 673                         binmode IMG;
 674
 675                         my $forgetit = 0;
 676                         try {
 677                                 $pic->plot(\@sub_data) or die $pic->error;
 678                                 print IMG $pic->gd->$format;
 679                         } otherwise {
 680                                 my $e = shift;
 681                                 warn "Couldn't draw $file.pie.$vcol.$sub_graph.$format : $e";
 682                                 $forgetit = 1;
 683                         };
 684
 685                         close IMG;
 686
 687
 688                         push @pics,
 689                                 { file => "pie.$vcol.$sub_graph.$format",
 690                                   name => $r->{column_labels}->[$vcol].' (Pie)',
 691                                 } unless ($forgetit);
 692
 693                         last if ($sub_graph == $split);
 694                 }
 695
 696         }
 697
 698         return \@pics;
 699 }
 700
 701 sub draw_bars {
 702         my $r = shift;
 703         my $file = shift;
 704         my $data = $r->{data};
 705
 706         #my $logo = $doc->findvalue('/reporter/setup/files/chart_logo');
 707
 708         my @groups = @{ $r->{group_by_list} };
 709
 710
 711         my @values = (0 .. (scalar(@{$r->{column_labels}}) - 1));
 712         splice(@values,$_,1) for (reverse @groups);
 713
 714         my @pic_data;
 715         {       no warnings;
 716                 for my $row (@$data) {
 717                         push @{$pic_data[0]}, join(' -- ', @$row[@groups]);
 718                 }
 719         }
 720
 721         my @leg;
 722         my $set = 1;
 723
 724         my %trim_candidates;
 725
 726         my $max_y = 0;
 727         for my $vcol (@values) {
 728                 next unless (defined $vcol);
 729                 $pic_data[$set] ||= [];
 730
 731                 my $pos = 0;
 732                 for my $row (@$data) {
 733                         my $val = $$row[$vcol] ? $$row[$vcol] : 0;
 734                         push @{$pic_data[$set]}, $val;
 735                         $max_y = $val if ($val > $max_y);
 736                         $trim_candidates{$pos}++ if ($val == 0);
 737                         $pos++;
 738                 }
 739
 740                 $set++;
 741         }
 742         my $set_count = scalar(@pic_data) - 1;
 743         my @trim_cols = grep { $trim_candidates{$_} == $set_count } keys %trim_candidates;
 744
 745         my @new_data;
 746         my @use_me;
 747         my @no_use;
 748         my $set_index = 0;
 749         for my $dataset (@pic_data) {
 750                 splice(@$dataset,$_,1) for (reverse sort @trim_cols);
 751
 752                 if (grep { $_ } @$dataset) {
 753                         push @new_data, $dataset;
 754                         push @use_me, $set_index if ($set_index > 0);
 755                 } else {
 756                         push @no_use, $set_index;
 757                 }
 758                 $set_index++;
 759
 760         }
 761
 762         return [] unless ($new_data[0] && @{$new_data[0]});
 763
 764         for my $col (@use_me) {
 765                 push @leg, $r->{column_labels}->[$values[$col - 1]];
 766         }
 767
 768         my $w = 100 + 10 * scalar(@{$new_data[0]});
 769         $w = 400 if ($w < 400);
 770
 771         my $h = 10 * (scalar(@new_data) / 2);
 772
 773         $h = 0 if ($h < 0);
 774
 775         my $pic = new GD::Graph::bars3d ($w + 250, $h + 500);
 776
 777         $pic->set(
 778                 title                   => $r->{report}{name},
 779                 x_labels_vertical       => 1,
 780                 shading                 => 1,
 781                 bar_depth               => 5,
 782                 bar_spacing             => 2,
 783                 y_max_value             => $max_y,
 784                 legend_placement        => 'TR',
 785                 boxclr                  => 'lgray',
 786                 #logo                   => $logo,
 787                 #logo_position          => 'R',
 788                 #logo_resize            => 0.5,
 789                 show_values             => 1,
 790                 overwrite               => 1,
 791         );
 792         $pic->set_legend(@leg);
 793
 794         my $format = $pic->export_format;
 795
 796         open(IMG, ">$file.bar.$format") or die "Cannot write '$file.bar.$format'";
 797         binmode IMG;
 798
 799         try {
 800                 $pic->plot(\@new_data) or die $pic->error;
 801                 print IMG $pic->gd->$format;
 802         } otherwise {
 803                 my $e = shift;
 804                 warn "Couldn't draw $file.bar.$format : $e";
 805         };
 806
 807         close IMG;
 808
 809         return [{ file => "bar.$format",
 810                   name => $r->{report}{name}.' (Bar)',
 811                 }];
 812
 813 }
 814
 815 sub draw_lines {
 816         my $r    = shift;
 817         my $file = shift;
 818         my $data = $r->{data};
 819
 820         #my $logo = $doc->findvalue('/reporter/setup/files/chart_logo');
 821
 822         my @groups = @{ $r->{group_by_list} };
 823
 824         my @values = (0 .. (scalar(@{$r->{column_labels}}) - 1));
 825         splice(@values,$_,1) for (reverse @groups);
 826
 827         my @pic_data;
 828         {       no warnings;
 829                 for my $row (@$data) {
 830                         push @{$pic_data[0]}, join(' -- ', @$row[@groups]);
 831                 }
 832         }
 833
 834         my @leg;
 835         my $set = 1;
 836
 837         my $max_y = 0;
 838         for my $vcol (@values) {
 839                 next unless (defined $vcol);
 840                 $pic_data[$set] ||= [];
 841
 842
 843                 for my $row (@$data) {
 844                         my $val = $$row[$vcol] ? $$row[$vcol] : 0;
 845                         push @{$pic_data[$set]}, $val;
 846                         $max_y = $val if ($val > $max_y);
 847                 }
 848
 849                 $set++;
 850         }
 851         my $set_count = scalar(@pic_data) - 1;
 852
 853         my @new_data;
 854         my @use_me;
 855         my @no_use;
 856         my $set_index = 0;
 857         for my $dataset (@pic_data) {
 858
 859                 if (grep { $_ } @$dataset) {
 860                         push @new_data, $dataset;
 861                         push @use_me, $set_index if ($set_index > 0);
 862                 } else {
 863                         push @no_use, $set_index;
 864                 }
 865                 $set_index++;
 866
 867         }
 868
 869         return [] unless ($new_data[0] && @{$new_data[0]});
 870
 871         for my $col (@use_me) {
 872                 push @leg, $r->{column_labels}->[$values[$col - 1]];
 873         }
 874
 875         my $w = 100 + 10 * scalar(@{$new_data[0]});
 876         $w = 400 if ($w < 400);
 877
 878         my $h = 10 * (scalar(@new_data) / 2);
 879
 880         $h = 0 if ($h < 0);
 881
 882         my $pic = new GD::Graph::lines3d ($w + 250, $h + 500);
 883
 884         $pic->set(
 885                 title                   => $r->{report}{name},
 886                 x_labels_vertical       => 1,
 887                 shading                 => 1,
 888                 line_depth              => 5,
 889                 y_max_value             => $max_y,
 890                 legend_placement        => 'TR',
 891                 boxclr                  => 'lgray',
 892                 #logo                   => $logo,
 893                 #logo_position          => 'R',
 894                 #logo_resize            => 0.5,
 895                 show_values             => 1,
 896                 overwrite               => 1,
 897         );
 898         $pic->set_legend(@leg);
 899
 900         my $format = $pic->export_format;
 901
 902         open(IMG, ">$file.line.$format") or die "Cannot write '$file.line.$format'";
 903         binmode IMG;
 904
 905         try {
 906                 $pic->plot(\@new_data) or die $pic->error;
 907                 print IMG $pic->gd->$format;
 908         } otherwise {
 909                 my $e = shift;
 910                 warn "Couldn't draw $file.line.$format : $e";
 911         };
 912
 913         close IMG;
 914
 915         return [{ file => "line.$format",
 916                   name => $r->{report}{name}.' (Bar)',
 917                 }];
 918
 919 }
 920
 921
 922 sub pivot_data {
 923         my $blob        = shift;
 924         my $pivot_label = shift;
 925         my $pivot_data  = shift;
 926         my $default     = shift;
 927         $default = 0 unless (defined $default);
 928
 929         my $data = $$blob{data};
 930         my $cols = $$blob{columns};
 931
 932         my @keep_labels =  @$cols;
 933         splice(@keep_labels, $_ - 1, 1) for (reverse sort ($pivot_label, $pivot_data));
 934
 935         my @keep_cols = (0 .. @$cols - 1);
 936         splice(@keep_cols, $_ - 1, 1) for (reverse sort ($pivot_label, $pivot_data));
 937
 938         my @gb = ( 0 .. @keep_cols - 1);
 939
 940         #first, find the unique list of pivot values
 941         my %tmp;
 942         for my $row (@$data) {
 943                 $tmp{ $$row[$pivot_label - 1] } = 1;
 944         }
 945         my @new_cols = sort keys %tmp;
 946
 947         tie my %split_data, 'Tie::IxHash';
 948         for my $row (@$data) {
 949
 950                 my $row_fp = ''. join('', map { defined($$row[$_]) ? $$row[$_] : '' } @keep_cols);
 951                 $split_data{$row_fp} ||= [];
 952
 953                 push @{ $split_data{$row_fp} }, $row;
 954         }
 955
 956
 957         #now loop over the data, building a new result set
 958         tie my %new_data, 'Tie::IxHash';
 959
 960         for my $fp ( keys %split_data ) {
 961
 962                 $new_data{$fp} = [];
 963
 964                 for my $col (@keep_cols) {
 965                         push @{ $new_data{$fp} }, $split_data{$fp}[0][$col];
 966                 }
 967
 968                 for my $col (@new_cols) {
 969
 970                         my ($datum) = map { $_->[$pivot_data - 1] } grep { $_->[$pivot_label - 1] eq $col } @{ $split_data{$fp} };
 971                         $datum ||= $default;
 972                         push @{ $new_data{$fp} }, $datum;
 973                 }
 974         }
 975
 976         push @keep_labels, @new_cols;
 977
 978         return { columns => \@keep_labels, data => [ values %new_data ], group_by_list => \@gb };
 979 }
 980
 981