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