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