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