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