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