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