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