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

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