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