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

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