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

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use diagnostics;
   5 use DBI;
   6 use FileHandle;
   7 use XML::LibXML;
   8 use Getopt::Long;
   9 use DateTime;
  10 use DateTime::Format::ISO8601;
  11 use JSON;
  12 use Data::Dumper;
  13 use OpenILS::WWW::Reporter::transforms;
  14 use Text::CSV_XS;
  15 use Spreadsheet::WriteExcel;
  16 use OpenSRF::EX qw/:try/;
  17 use OpenSRF::Utils qw/:daemon/;
  18 use OpenSRF::Utils::Logger qw/:level/;
  19 use POSIX;
  20 use GD::Graph::pie;
  21 use GD::Graph::bars3d;
  22 use GD::Graph::lines3d;
  23
  24 use open ':utf8';
  25
  26
  27 my ($base_xml, $count, $daemon) = ('/openils/conf/reporter.xml', 1);
  28
  29 GetOptions(
  30         "file=s"        => \$base_xml,
  31         "daemon"        => \$daemon,
  32         "concurrency=i" => \$count,
  33 );
  34
  35 my $parser = XML::LibXML->new;
  36 $parser->expand_xinclude(1);
  37
  38 my $doc = $parser->parse_file($base_xml);
  39
  40 my $db_driver = $doc->findvalue('/reporter/setup/database/driver');
  41 my $db_host = $doc->findvalue('/reporter/setup/database/host');
  42 my $db_name = $doc->findvalue('/reporter/setup/database/name');
  43 my $db_user = $doc->findvalue('/reporter/setup/database/user');
  44 my $db_pw = $doc->findvalue('/reporter/setup/database/password');
  45
  46 my $dsn = "dbi:" . $db_driver . ":dbname=" . $db_name .';host=' . $db_host;
  47
  48 my ($dbh,$running,$sth,@reports,$run, $current_time);
  49
  50 daemonize("Clark Kent, waiting for trouble") if ($daemon);
  51
  52 DAEMON:
  53
  54 $dbh = DBI->connect($dsn,$db_user,$db_pw, {pg_enable_utf8 => 1, RaiseError => 1});
  55
  56 $current_time = DateTime->from_epoch( epoch => time() )->strftime('%FT%T%z');
  57 # Move new reports into the run queue
  58 $dbh->do(<<'SQL', {}, $current_time);
  59 INSERT INTO reporter.output ( stage3, state )
  60         SELECT  id, 'wait'
  61           FROM  reporter.stage3
  62           WHERE runtime <= $1
  63                 AND (   (       recurrence = '0 seconds'::INTERVAL
  64                                 AND (
  65                                         id NOT IN ( SELECT stage3 FROM reporter.output )
  66                                         OR rerun IS TRUE
  67                                 )
  68                         )
  69                         OR (    recurrence > '0 seconds'::INTERVAL
  70                                 AND id NOT IN (
  71                                         SELECT  stage3
  72                                           FROM  reporter.output
  73                                           WHERE state <> 'complete')
  74                         )
  75                 )
  76           ORDER BY runtime;
  77 SQL
  78
  79 # make sure we're not already running $count reports
  80 ($running) = $dbh->selectrow_array(<<SQL);
  81 SELECT  count(*)
  82   FROM  reporter.output
  83   WHERE state = 'running';
  84 SQL
  85
  86 if ($count <= $running) {
  87         if ($daemon) {
  88                 $dbh->disconnect;
  89                 sleep 1;
  90                 POSIX::waitpid( -1, POSIX::WNOHANG );
  91                 sleep 60;
  92                 goto DAEMON;
  93         }
  94         print "Already running maximum ($running) concurrent reports\n";
  95         exit 1;
  96 }
  97
  98 # if we have some open slots then generate the sql
  99 $run = $count - $running;
 100
 101 $sth = $dbh->prepare(<<SQL);
 102 SELECT  *
 103   FROM  reporter.output
 104   WHERE state = 'wait'
 105   ORDER BY queue_time
 106   LIMIT $run;
 107 SQL
 108
 109 $sth->execute;
 110
 111 @reports = ();
 112 while (my $r = $sth->fetchrow_hashref) {
 113         my $s3 = $dbh->selectrow_hashref(<<"    SQL", {}, $r->{stage3});
 114                 SELECT * FROM reporter.stage3 WHERE id = ?;
 115         SQL
 116
 117         my $s2 = $dbh->selectrow_hashref(<<"    SQL", {}, $s3->{stage2});
 118                 SELECT * FROM reporter.stage2 WHERE id = ?;
 119         SQL
 120
 121         $s3->{stage2} = $s2;
 122         $r->{stage3} = $s3;
 123
 124         generate_query( $r );
 125         push @reports, $r;
 126 }
 127
 128 $sth->finish;
 129
 130 $dbh->disconnect;
 131
 132 # Now we spaun the report runners
 133
 134 for my $r ( @reports ) {
 135         next if (safe_fork());
 136
 137         # This is the child (runner) process;
 138         my $p = JSON->JSON2perl( $r->{stage3}->{params} );
 139         daemonize("Clark Kent reporting: $p->{reportname}");
 140
 141         $dbh = DBI->connect($dsn,$db_user,$db_pw, {pg_enable_utf8 => 1, RaiseError => 1});
 142
 143         try {
 144                 $dbh->do(<<'            SQL',{}, $r->{sql}->{'select'}, $$, $r->{id});
 145                         UPDATE  reporter.output
 146                           SET   state = 'running',
 147                                 run_time = 'now',
 148                                 query = ?,
 149                                 run_pid = ?
 150                           WHERE id = ?;
 151                 SQL
 152
 153                 my ($runtime) = $dbh->selectrow_array("SELECT run_time FROM reporter.output WHERE id = ?",{},$r->{id});
 154                 $r->{run_time} = $runtime;
 155
 156                 $sth = $dbh->prepare($r->{sql}->{'select'});
 157
 158                 $sth->execute(@{ $r->{sql}->{'bind'} });
 159                 $r->{data} = $sth->fetchall_arrayref;
 160
 161                 pivot_data($r);
 162
 163                 my $base = $doc->findvalue('/reporter/setup/files/output_base');
 164                 my $s1 = $r->{stage3}->{stage2}->{stage1};
 165                 my $s2 = $r->{stage3}->{stage2}->{id};
 166                 my $s3 = $r->{stage3}->{id};
 167                 my $output = $r->{id};
 168
 169                 mkdir($base);
 170                 mkdir("$base/$s1");
 171                 mkdir("$base/$s1/$s2");
 172                 mkdir("$base/$s1/$s2/$s3");
 173                 mkdir("$base/$s1/$s2/$s3/$output");
 174
 175                 my @formats;
 176                 if (ref $p->{output_format}) {
 177                         @formats = @{ $p->{output_format} };
 178                 } else {
 179                         @formats = ( $p->{output_format} );
 180                 }
 181
 182                 if ( grep { $_ eq 'csv' } @formats ) {
 183                         build_csv("$base/$s1/$s2/$s3/$output/report-data.csv", $r);
 184                 }
 185
 186                 if ( grep { $_ eq 'excel' } @formats ) {
 187                         build_excel("$base/$s1/$s2/$s3/$output/report-data.xls", $r);
 188                 }
 189
 190                 if ( grep { $_ eq 'html' } @formats ) {
 191                         mkdir("$base/$s1/$s2/$s3/$output/html");
 192                         build_html("$base/$s1/$s2/$s3/$output/report-data.html", $r);
 193                 }
 194
 195
 196                 $dbh->begin_work;
 197                 $dbh->do(<<'            SQL',{}, $r->{run_time}, $r->{stage3}->{id});
 198                         UPDATE  reporter.stage3
 199                           SET   runtime = CAST(? AS TIMESTAMP WITH TIME ZONE) + recurrence
 200                           WHERE id = ? AND recurrence > '0 seconds'::INTERVAL;
 201                 SQL
 202                 $dbh->do(<<'            SQL',{}, $r->{stage3}->{id});
 203                         UPDATE  reporter.stage3
 204                           SET   rerun = FALSE
 205                           WHERE id = ? AND rerun = TRUE;
 206                 SQL
 207                 $dbh->do(<<'            SQL',{}, $r->{id});
 208                         UPDATE  reporter.output
 209                           SET   state = 'complete',
 210                                 complete_time = 'now'
 211                           WHERE id = ?;
 212                 SQL
 213                 $dbh->commit;
 214
 215
 216         } otherwise {
 217                 my $e = shift;
 218                 $dbh->rollback;
 219                 $dbh->do(<<'            SQL',{}, $e, $r->{id});
 220                         UPDATE  reporter.output
 221                           SET   state = 'error',
 222                                 error_time = 'now',
 223                                 error = ?,
 224                                 run_pid = NULL
 225                           WHERE id = ?;
 226                 SQL
 227         };
 228
 229         $dbh->disconnect;
 230
 231         exit; # leave the child
 232 }
 233
 234 if ($daemon) {
 235         sleep 1;
 236         POSIX::waitpid( -1, POSIX::WNOHANG );
 237         sleep 60;
 238         goto DAEMON;
 239 }
 240
 241 #-------------------------------------------------------------------
 242
 243 sub pivot_data {
 244         my $r = shift;
 245         my $p = JSON->JSON2perl( $r->{stage3}->{params} );
 246         my $settings = $r->{sql};
 247         my $data = $r->{data};
 248
 249         return unless (defined($settings->{pivot}));
 250
 251         my @groups = (map { ($_ - 1) } @{ $settings->{groupby} });
 252         my @values = (0 .. (scalar(@{$settings->{columns}}) - 1));
 253         splice(@values,$_,1) for (reverse @groups);
 254
 255         # remove pivot from group-by
 256         my $count = 0;
 257         my $pivot_groupby;
 258         while ($count < scalar(@{$settings->{groupby}})) {
 259                 if (defined $pivot_groupby) {
 260                         $settings->{groupby}->[$count] -= 1;
 261                         if ($settings->{groupby}->[$count] >= $values[0] + 1) {
 262                                 $settings->{groupby}->[$count] -= 1;
 263                         }
 264                 } elsif ($settings->{groupby}->[$count] == $settings->{pivot} + 1) {
 265                         $pivot_groupby = $count;
 266                 }
 267                 $count++;
 268         }
 269
 270
 271         # grab positions of non-group-bys
 272         @values = (0 .. (scalar(@{$settings->{columns}}) - 1));
 273         splice(@values,$_,1) for (reverse @groups);
 274
 275         # we're only doing one "value" for now, so grab that and remove from headings
 276         my ($val_col) = @values;
 277
 278         my @remove_me = sort
 279                 { $b <=> $a }
 280                 ($val_col, $settings->{groupby}->[$pivot_groupby] - 1);
 281
 282         my %p_header;
 283         for my $row (@$data) {
 284                 $p_header{ $$row[$settings->{pivot}] } = [] unless exists($p_header{ $$row[$settings->{pivot}] });
 285
 286                 push @{ $p_header{ $$row[$settings->{pivot}] } }, $$row[$val_col];
 287
 288                 splice(@$row,$_,1) for (@remove_me);
 289         }
 290
 291         push @{ $settings->{columns} }, sort keys %p_header;
 292
 293         # remove from headings;
 294         splice(@{$settings->{columns}},$_,1) for (@remove_me);
 295
 296         # remove pivot from groupby
 297         splice(@{$settings->{groupby}}, $pivot_groupby, 1);
 298         @groups = (map { ($_ - 1) } @{ $settings->{groupby} });
 299
 300         $count = scalar(keys %p_header);
 301         my %seenit;
 302         my @new_data;
 303         {       no warnings;
 304                 for my $row (@$data) {
 305
 306                         my $fingerprint = join('',@$row[@groups]);
 307                         next if $seenit{$fingerprint};
 308
 309                         $seenit{$fingerprint}++;
 310
 311                         for my $h ( sort keys %p_header ) {
 312                                 push @$row, shift(@{ $p_header{$h} });
 313                         }
 314
 315                         push @new_data, [@$row];
 316                 }
 317         }
 318
 319         #replace old data with new
 320         $r->{data} = \@new_data;
 321
 322 }
 323
 324 sub build_csv {
 325         my $file = shift;
 326         my $r = shift;
 327
 328         my $csv = Text::CSV_XS->new({ always_quote => 1, eol => "\015\012" });
 329         my $f = new FileHandle (">$file");
 330
 331         $csv->print($f, $r->{sql}->{columns});
 332         $csv->print($f, $_) for (@{$r->{data}});
 333
 334         $f->close;
 335 }
 336 sub build_excel {
 337         my $file = shift;
 338         my $r = shift;
 339         my $p = JSON->JSON2perl( $r->{stage3}->{params} );
 340
 341         my $xls = Spreadsheet::WriteExcel->new($file);
 342
 343         my $sheetname = substr($p->{reportname},1,31);
 344         $sheetname =~ s/\W/_/gos;
 345
 346         my $sheet = $xls->add_worksheet($sheetname);
 347
 348         $sheet->write_row('A1', $r->{sql}->{columns});
 349
 350         $sheet->write_col('A2', $r->{data});
 351
 352         $xls->close;
 353 }
 354
 355 sub build_html {
 356         my $file = shift;
 357         my $r = shift;
 358         my $p = JSON->JSON2perl( $r->{stage3}->{params} );
 359
 360         my $index = new FileHandle (">$file");
 361         my $raw = new FileHandle (">$file.raw.html");
 362
 363         # index header
 364         print $index <<"        HEADER";
 365 <html>
 366         <head>
 367                 <title>$$p{reportname}</title>
 368                 <style>
 369                         table { border-collapse: collapse; }
 370                         th { background-color: lightgray; }
 371                         td,th { border: solid black 1px; }
 372                         * { font-family: sans-serif; font-size: 10px; }
 373                 </style>
 374         </head>
 375         <body>
 376                 <h2><u>$$p{reportname}</u></h2>
 377         HEADER
 378
 379
 380         # add a link to the raw output html
 381         print $index "<a href='report-data.html.raw.html'>Raw output data</a><br/><br/><br/><br/>";
 382
 383         # create the raw output html file
 384         print $raw "<html><head><title>$$p{reportname}</title>";
 385
 386         print $raw <<'  CSS';
 387                 <style>
 388                         table { border-collapse: collapse; }
 389                         th { background-color: lightgray; }
 390                         td,th { border: solid black 1px; }
 391                         * { font-family: sans-serif; font-size: 10px; }
 392                 </style>
 393         CSS
 394
 395         print $raw "</head><body><table>";
 396
 397         {       no warnings;
 398                 print $raw "<tr><th>".join('</th><th>',@{$r->{sql}->{columns}}).'</th></tr>';
 399                 print $raw "<tr><td>".join('</td><td>',@$_                    ).'</td></tr>' for (@{$r->{data}});
 400         }
 401
 402         print $raw '</table></body></html>';
 403
 404         $raw->close;
 405
 406         # get the graph types
 407         my @graphs;
 408         if (ref $$p{html_graph_type}) {
 409                 @graphs = @{ $$p{html_graph_type} };
 410         } else {
 411                 @graphs = ( $$p{html_graph_type} );
 412         }
 413
 414         # Time for a pie chart
 415         if (grep {$_ eq 'pie'} @graphs) {
 416                 my $pics = draw_pie($r, $p, $file);
 417                 for my $pic (@$pics) {
 418                         print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/><br/><br/><br/><br/>";
 419                 }
 420         }
 421
 422         print $index '<br/><br/><br/><br/>';
 423         # Time for a bar chart
 424         if (grep {$_ eq 'bar'} @graphs) {
 425                 my $pics = draw_bars($r, $p, $file);
 426                 for my $pic (@$pics) {
 427                         print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/><br/><br/><br/><br/>";
 428                 }
 429         }
 430
 431         print $index '<br/><br/><br/><br/>';
 432         # Time for a bar chart
 433         if (grep {$_ eq 'line'} @graphs) {
 434                 my $pics = draw_lines($r, $p, $file);
 435                 for my $pic (@$pics) {
 436                         print $index "<img src='report-data.html.$pic->{file}' alt='$pic->{name}'/><br/><br/><br/><br/>";
 437                 }
 438         }
 439
 440
 441         # and that's it!
 442         print $index '</body></html>';
 443
 444         $index->close;
 445 }
 446
 447 sub draw_pie {
 448         my $r = shift;
 449         my $p = shift;
 450         my $file = shift;
 451         my $data = $r->{data};
 452         my $settings = $r->{sql};
 453
 454         my @groups = (map { ($_ - 1) } @{ $settings->{groupby} });
 455
 456         my @values = (0 .. (scalar(@{$settings->{columns}}) - 1));
 457         delete @values[@groups];
 458
 459         my $logo = $doc->findvalue('/reporter/setup/files/chart_logo');
 460
 461         my @pics;
 462         for my $vcol (@values) {
 463                 next unless (defined $vcol);
 464
 465                 my @pic_data = ([],[]);
 466                 for my $row (@$data) {
 467                         next if (!defined($$row[$vcol]) || $$row[$vcol] == 0);
 468                         my $val = $$row[$vcol];
 469                         push @{$pic_data[0]}, join(" -- ", @$row[@groups])." ($val)";
 470                         push @{$pic_data[1]}, $val;
 471                 }
 472
 473                 next unless (@{$pic_data[0]});
 474
 475                 my $size = 300;
 476                 my $split = int(scalar(@{$pic_data[0]}) / $size);
 477                 my $last = scalar(@{$pic_data[0]}) % $size;
 478
 479                 for my $sub_graph (0 .. $split) {
 480
 481                         if ($sub_graph == $split) {
 482                                 $size = $last;
 483                         }
 484
 485                         my @sub_data;
 486                         for my $set (@pic_data) {
 487                                 push @sub_data, [ splice(@$set,0,$size) ];
 488                         }
 489
 490                         my $pic = new GD::Graph::pie;
 491
 492                         $pic->set(
 493                                 label                   => $settings->{columns}->[$vcol],
 494                                 start_angle             => 180,
 495                                 legend_placement        => 'R',
 496                                 logo                    => $logo,
 497                                 logo_position           => 'TL',
 498                                 logo_resize             => 0.5,
 499                                 show_values             => 1,
 500                         );
 501
 502                         my $format = $pic->export_format;
 503
 504                         open(IMG, ">$file.pie.$vcol.$sub_graph.$format");
 505                         binmode IMG;
 506
 507                         my $forgetit = 0;
 508                         try {
 509                                 $pic->plot(\@sub_data) or die $pic->error;
 510                                 print IMG $pic->gd->$format;
 511                         } otherwise {
 512                                 my $e = shift;
 513                                 warn "Couldn't draw $file.pie.$vcol.$sub_graph.$format : $e";
 514                                 $forgetit = 1;
 515                         };
 516
 517                         close IMG;
 518
 519
 520                         push @pics,
 521                                 { file => "pie.$vcol.$sub_graph.$format",
 522                                   name => $settings->{columns}->[$vcol].' (Pie)',
 523                                 } unless ($forgetit);
 524
 525                         last if ($sub_graph == $split);
 526                 }
 527
 528         }
 529
 530         return \@pics;
 531 }
 532
 533 sub draw_bars {
 534         my $r = shift;
 535         my $p = shift;
 536         my $file = shift;
 537         my $data = $r->{data};
 538         my $settings = $r->{sql};
 539
 540         my $logo = $doc->findvalue('/reporter/setup/files/chart_logo');
 541
 542         my @groups = (map { ($_ - 1) } @{ $settings->{groupby} });
 543
 544
 545         my @values = (0 .. (scalar(@{$settings->{columns}}) - 1));
 546         splice(@values,$_,1) for (reverse @groups);
 547
 548         my @pic_data;
 549         {       no warnings;
 550                 for my $row (@$data) {
 551                         push @{$pic_data[0]}, join(' -- ', @$row[@groups]);
 552                 }
 553         }
 554
 555         my @leg;
 556         my $set = 1;
 557
 558         my %trim_candidates;
 559
 560         my $max_y = 0;
 561         for my $vcol (@values) {
 562                 next unless (defined $vcol);
 563
 564
 565                 my $pos = 0;
 566                 for my $row (@$data) {
 567                         my $val = $$row[$vcol] ? $$row[$vcol] : 0;
 568                         push @{$pic_data[$set]}, $val;
 569                         $max_y = $val if ($val > $max_y);
 570                         $trim_candidates{$pos}++ if ($val == 0);
 571                         $pos++;
 572                 }
 573
 574                 $set++;
 575         }
 576         my $set_count = scalar(@pic_data) - 1;
 577         my @trim_cols = grep { $trim_candidates{$_} == $set_count } keys %trim_candidates;
 578
 579         my @new_data;
 580         my @use_me;
 581         my @no_use;
 582         my $set_index = 0;
 583         for my $dataset (@pic_data) {
 584                 splice(@$dataset,$_,1) for (sort { $b <=> $a } @trim_cols);
 585
 586                 if (grep { $_ } @$dataset) {
 587                         push @new_data, $dataset;
 588                         push @use_me, $set_index;
 589                 } else {
 590                         push @no_use, $set_index;
 591                 }
 592                 $set_index++;
 593
 594         }
 595
 596         for my $col (@use_me) {
 597                 push @leg, $settings->{columns}->[$col + @groups - 1] if (map { 1 } grep { $col == $_ } @values);
 598         }
 599
 600         my $w = 100 + 10 * scalar(@{$new_data[0]});
 601         $w = 400 if ($w < 400);
 602
 603         my $h = 10 * (scalar(@new_data) / 2);
 604
 605         $h = 0 if ($h < 0);
 606
 607         my $pic = new GD::Graph::bars3d ($w + 250, $h + 500);
 608
 609         $pic->set(
 610                 title                   => $p->{reportname},
 611                 x_labels_vertical       => 1,
 612                 shading                 => 1,
 613                 bar_depth               => 5,
 614                 bar_spacing             => 2,
 615                 y_max_value             => $max_y,
 616                 legend_placement        => 'TR',
 617                 boxclr                  => 'lgray',
 618                 logo                    => $logo,
 619                 logo_position           => 'R',
 620                 logo_resize             => 0.5,
 621                 show_values             => 1,
 622                 overwrite               => 1,
 623         );
 624         $pic->set_legend(@leg);
 625
 626         my $format = $pic->export_format;
 627
 628         open(IMG, ">$file.bar.$format");
 629         binmode IMG;
 630
 631         try {
 632                 $pic->plot(\@new_data) or die $pic->error;
 633                 print IMG $pic->gd->$format;
 634         } otherwise {
 635                 my $e = shift;
 636                 warn "Couldn't draw $file.bar.$format : $e";
 637         };
 638
 639         close IMG;
 640
 641         return [{ file => "bar.$format",
 642                   name => $p->{reportname}.' (Bar)',
 643                 }];
 644
 645 }
 646
 647 sub draw_lines {
 648         my $r = shift;
 649         my $p = shift;
 650         my $file = shift;
 651         my $data = $r->{data};
 652         my $settings = $r->{sql};
 653
 654         my $logo = $doc->findvalue('/reporter/setup/files/chart_logo');
 655
 656         my @groups = (map { ($_ - 1) } @{ $settings->{groupby} });
 657
 658
 659         my @values = (0 .. (scalar(@{$settings->{columns}}) - 1));
 660         splice(@values,$_,1) for (reverse @groups);
 661
 662         my @pic_data;
 663         {       no warnings;
 664                 for my $row (@$data) {
 665                         push @{$pic_data[0]}, join(' -- ', @$row[@groups]);
 666                 }
 667         }
 668
 669         my @leg;
 670         my $set = 1;
 671
 672         my $max_y = 0;
 673         for my $vcol (@values) {
 674                 next unless (defined $vcol);
 675
 676
 677                 for my $row (@$data) {
 678                         my $val = $$row[$vcol] ? $$row[$vcol] : 0;
 679                         push @{$pic_data[$set]}, $val;
 680                         $max_y = $val if ($val > $max_y);
 681                 }
 682
 683                 $set++;
 684         }
 685         my $set_count = scalar(@pic_data) - 1;
 686
 687         my @new_data;
 688         my @use_me;
 689         my @no_use;
 690         my $set_index = 0;
 691         for my $dataset (@pic_data) {
 692
 693                 if (grep { $_ } @$dataset) {
 694                         push @new_data, $dataset;
 695                         push @use_me, $set_index;
 696                 } else {
 697                         push @no_use, $set_index;
 698                 }
 699                 $set_index++;
 700
 701         }
 702
 703         for my $col (@use_me) {
 704                 push @leg, $settings->{columns}->[$col + @groups - 1] if (map { 1 } grep { $col == $_ } @values);
 705         }
 706
 707         my $w = 100 + 10 * scalar(@{$new_data[0]});
 708         $w = 400 if ($w < 400);
 709
 710         my $h = 10 * (scalar(@new_data) / 2);
 711
 712         $h = 0 if ($h < 0);
 713
 714         my $pic = new GD::Graph::lines3d ($w + 250, $h + 500);
 715
 716         $pic->set(
 717                 title                   => $p->{reportname},
 718                 x_labels_vertical       => 1,
 719                 shading                 => 1,
 720                 line_depth              => 5,
 721                 y_max_value             => $max_y,
 722                 legend_placement        => 'TR',
 723                 boxclr                  => 'lgray',
 724                 logo                    => $logo,
 725                 logo_position           => 'R',
 726                 logo_resize             => 0.5,
 727                 show_values             => 1,
 728                 overwrite               => 1,
 729         );
 730         $pic->set_legend(@leg);
 731
 732         my $format = $pic->export_format;
 733
 734         open(IMG, ">$file.line.$format");
 735         binmode IMG;
 736
 737         try {
 738                 $pic->plot(\@new_data) or die $pic->error;
 739                 print IMG $pic->gd->$format;
 740         } otherwise {
 741                 my $e = shift;
 742                 warn "Couldn't draw $file.line.$format : $e";
 743         };
 744
 745         close IMG;
 746
 747         return [{ file => "line.$format",
 748                   name => $p->{reportname}.' (Bar)',
 749                 }];
 750
 751 }
 752
 753 sub table_by_id {
 754         my $id = shift;
 755         my ($node) = $doc->findnodes("//*[\@id='$id']");
 756         if ($node && $node->findvalue('@table')) {
 757                 ($node) = $doc->findnodes("//*[\@id='".$node->getAttribute('table')."']");
 758         }
 759         return $node;
 760 }
 761
 762 sub generate_query {
 763         my $r = shift;
 764
 765         my $p = JSON->JSON2perl( $r->{stage3}->{params} );
 766
 767         my @group_by = ();
 768         my @aggs = ();
 769         my $core = $r->{stage3}->{stage2}->{stage1};
 770         my @dims = ();
 771
 772         for my $t (keys %{$$p{filter}}) {
 773                 if ($t ne $core) {
 774                         push @dims, $t;
 775                 }
 776         }
 777
 778         for my $t (keys %{$$p{output}}) {
 779                 if ($t ne $core && !(grep { $t eq $_ } @dims) ) {
 780                         push @dims, $t;
 781                 }
 782         }
 783
 784         my @dim_select = ();
 785         my @dim_from = ();
 786         for my $d (@dims) {
 787                 my $t = table_by_id($d);
 788                 my $t_name = $t->findvalue('tablename');
 789                 push @dim_from, "$t_name AS \"$d\"";
 790
 791                 my $k = $doc->findvalue("//*[\@id='$d']/\@key");
 792                 push @dim_select, "\"$d\".\"$k\" AS \"${d}_${k}\"";
 793
 794                 for my $c ( keys %{$$p{output}{$d}} ) {
 795                         push @dim_select, "\"$d\".\"$c\" AS \"${d}_${c}\"";
 796                 }
 797
 798                 for my $c ( keys %{$$p{filter}{$d}} ) {
 799                         next if (exists $$p{output}{$d}{$c});
 800                         push @dim_select, "\"$d\".\"$c\" AS \"${d}_${c}\"";
 801                 }
 802         }
 803
 804         my $d_select =
 805                 '(SELECT ' . join(',', @dim_select) .
 806                 '  FROM ' . join(',', @dim_from) . ') AS dims';
 807
 808         my @opord = ();
 809         if (ref $$p{output_order}) {
 810                 @opord = @{ $$p{output_order} };
 811         } else {
 812                 @opord = ( $$p{output_order} );
 813         }
 814         my @output_order = map { { (split ':')[1] => (split ':')[2] } } @opord;
 815         my @p_col = split(':',$p->{pivot_col}) if $p->{pivot_col};
 816         my $pivot = undef;
 817
 818         my $col = 1;
 819         my @groupby = ();
 820         my @output = ();
 821         my @columns = ();
 822         my @join = ();
 823         my @join_base = ();
 824         for my $pair (@output_order) {
 825                 my ($t_name) = keys %$pair;
 826                 my $t = $t_name;
 827
 828                 $t_name = "dims" if ($t ne $core);
 829
 830                 my $t_node = table_by_id($t);
 831
 832                 for my $c ( values %$pair ) {
 833                         my $label = $t_node->findvalue("fields/field[\@name='$c']/label");
 834
 835                         my $full_col = $c;
 836                         $full_col = "${t}_${c}" if ($t ne $t_name);
 837                         $full_col = "\"$t_name\".\"$full_col\"";
 838
 839
 840                         if (my $xform_type = $$p{xform}{type}{$t}{$c}) {
 841                                 my $xform = $$OpenILS::WWW::Reporter::dtype_xforms{$xform_type};
 842                                 if ($xform->{group}) {
 843                                         push @groupby, $col;
 844                                 }
 845                                 $label = "$$xform{label} -- $label";
 846
 847                                 my $tmp = $xform->{'select'};
 848                                 $tmp =~ s/\?COLNAME\?/$full_col/gs;
 849                                 $tmp =~ s/\?PARAM\?/$$p{xform}{param}{$t}{$c}/gs;
 850                                 $full_col = $tmp;
 851                         } else {
 852                                 push @groupby, $col;
 853                         }
 854
 855                         push @output, "$full_col AS \"$label\"";
 856                         push @columns, $label;
 857                         $pivot = scalar(@columns) - 1 if (@p_col && $t eq $p_col[1] && $c eq $p_col[2]);
 858                         $col++;
 859                 }
 860
 861                 if ($t ne $t_name && (!@join_base || !grep{$t eq $_}@join_base)) {
 862                         my $k = $doc->findvalue("//*[\@id='$t']/\@key");
 863                         my $f = $doc->findvalue("//*[\@id='$t']/\@field");
 864                         push @join, "dims.\"${t}_${k}\" = \"$core\".\"$f\"";
 865                         push @join_base, $t;
 866                 }
 867         }
 868
 869         my @where = ();
 870         my @bind = ();
 871         for my $t ( keys %{$$p{filter}} ) {
 872                 my $t_name = $t;
 873                 $t_name = "dims" if ($t ne $core);
 874
 875                 my $t_node = table_by_id($t);
 876
 877                 for my $c ( keys %{$$p{filter}{$t}} ) {
 878                         my $label = $t_node->findvalue("fields/field[\@name='$c']/label");
 879
 880                         my $full_col = $c;
 881                         $full_col = "${t}_${c}" if ($t ne $t_name);
 882                         $full_col = "\"$t_name\".\"$full_col\"";
 883
 884                         my ($fam) = keys %{ $$p{filter}{$t}{$c} };
 885                         my ($w) = keys %{ $$p{filter}{$t}{$c}{$fam} };
 886                         my $val = $$p{filter}{$t}{$c}{$fam}{$w};
 887
 888                         my $filter_code_xpath = "/reporter/widgets/widget-family[\@name='$fam']/widget[\@name='$w']/filter-code[\@type='perl']";
 889                         if (my $widget_code = $doc->findvalue($filter_code_xpath)) { # widget supplys it's own filter code
 890                                 my ($where_clause, $bind_list) = ('',[]);
 891
 892                                 eval $widget_code;
 893
 894                                 die "$@\n\n$widget_code" if ($@);
 895
 896                                 push @where, $where_clause;
 897                                 push @bind, @$bind_list;
 898
 899                         } elsif (ref $val) {
 900                                 push @where, "$full_col IN (".join(",",map {'?'}@$val).")";
 901                                 push @bind, @$val;
 902                         } else {
 903                                 push @where, "$full_col = ?";
 904                                 push @bind, $val;
 905                         }
 906                 }
 907
 908                 if ($t ne $t_name && (!@join_base || !grep{$t eq $_}@join_base)) {
 909                         my $k = $doc->findvalue("//*[\@id='$t']/\@key");
 910                         my $f = $doc->findvalue("//*[\@id='$t']/\@field");
 911                         push @join, "dims.\"${t}_${k}\" = \"$core\".\"$f\"";
 912                         push @join_base, $t;
 913                 }
 914         }
 915
 916         my $t = table_by_id($core)->findvalue('tablename');
 917
 918         my $from = " FROM $t AS \"$core\" ";
 919         $from .= "RIGHT JOIN $d_select ON (". join(' AND ', @join).")" if ( @join );
 920
 921         my $select =
 922                 "SELECT ".join(',', @output). $from;
 923
 924         $select .= ' WHERE '.join(' AND ', @where) if (@where);
 925         $select .= ' GROUP BY '.join(',',@groupby) if (@groupby);
 926
 927         $r->{sql}->{'pivot'}    = $pivot;
 928         $r->{sql}->{'select'}   = $select;
 929         $r->{sql}->{'bind'}     = \@bind;
 930         $r->{sql}->{columns}    = \@columns;
 931         $r->{sql}->{groupby}    = \@groupby;
 932
 933 }
 934
 935
 936
 937
 938
 939