Open-ILS/src/reporter/clark-kent.pl

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