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