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

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