lib/Yaala/Report/Combined.pm

   1 package Yaala::Report;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Exporter;
   7 use Yaala::Html qw#head foot escape navbar get_filename get_title#;
   8 use Yaala::Data::Core qw#receive get_values#;
   9 use Yaala::Data::Setup qw#$SELECTS#;
  10 use Yaala::Data::Convert qw#convert#;
  11 use Yaala::Config qw#get_config#;
  12 use Yaala::Report::Core qw#$OUTPUTDIR#;
  13 use Yaala::Report::GDGraph qw#generate_graph $GRAPH_WIDTH $GRAPH_HEIGHT#;
  14
  15 @Yaala::Report::EXPORT_OK = qw#generate#;
  16 @Yaala::Report::ISA = ('Exporter');
  17
  18 my $VERSION = '$Id: Combined.pm,v 1.10 2003/12/07 14:53:30 octo Exp $';
  19 print STDERR $/, __FILE__, ": $VERSION" if ($::DEBUG);
  20
  21 for (@$SELECTS)
  22 {
  23         my $sel = $_;
  24         while (scalar (@{$sel->[1]}) > 3)
  25         {
  26                 my $ignore = pop (@{$sel->[1]});
  27                 print STDERR $/, __FILE__, ": With the combined output only ",
  28                         "three fields are supported. ",
  29                         "Field ``$ignore'' will be ignored.";
  30         }
  31 }
  32
  33 return (1);
  34
  35 sub generate
  36 {
  37         for (@$SELECTS)
  38         {
  39                 my $sel = $_;
  40                 if (scalar (@{$sel->[1]}) == 1)
  41                 {
  42                         generate_1D_page ($sel);
  43                 }
  44                 elsif (scalar (@{$sel->[1]}) == 2)
  45                 {
  46                         generate_2D_page ($sel);
  47                 }
  48                 elsif (scalar (@{$sel->[1]}) == 3)
  49                 {
  50                         generate_3D_page ($sel);
  51                 }
  52                 else
  53                 {
  54                         die;
  55                 }
  56         }
  57
  58         generate_index_page ();
  59
  60         return (1);
  61 }
  62
  63 sub generate_1D_page
  64 {
  65         my $sel = shift;
  66         my ($key) = @{$sel->[1]};
  67
  68         my $filename = get_filename ($sel);
  69         my $title = get_title ($sel);
  70
  71         open (FH, '> ' . $OUTPUTDIR . $filename) or die ('open: ' . $!);
  72
  73         print FH head ($title, $title);
  74         print FH navbar ($sel);
  75
  76         print FH generate_1D_table ($sel, $key);
  77
  78         print FH foot ();
  79         close (FH);
  80 }
  81
  82 sub generate_2D_page
  83 {
  84         my $sel = shift;
  85         my ($key1, $key2) = @{$sel->[1]};
  86
  87         my $filename = get_filename ($sel);
  88         my $title = get_title ($sel);
  89
  90         open (FH, '> ' . $OUTPUTDIR . $filename) or die ('open: ' . $!);
  91
  92         print FH head ($title, $title);
  93         print FH navbar ($sel);
  94
  95         print FH generate_2D_table ($sel, $key1, $key2);
  96
  97         print FH foot ();
  98         close (FH);
  99 }
 100
 101 sub generate_3D_page
 102 {
 103         my $sel = shift;
 104         my ($key1, $key2, $key3) = @{$sel->[1]};
 105
 106         my $filename = get_filename ($sel);
 107         my $title = get_title ($sel);
 108
 109         open (FH, '> ' . $OUTPUTDIR . $filename) or die ('open: ' . $!);
 110
 111         print FH head ($title, $title);
 112         print FH navbar ($sel);
 113
 114         print FH generate_1D_table ($sel, $key3, 1);
 115
 116         my @vals3 = get_values ($sel, $key3);
 117
 118         for (sort (@vals3))
 119         {
 120                 my $val3 = $_;
 121                 print FH generate_2D_table ($sel, $key1, $key2, $key3, $val3);
 122         }
 123
 124         print FH foot ();
 125         close (FH);
 126 }
 127
 128 sub generate_index_page
 129 {
 130         open (FH, '> ' . $OUTPUTDIR . 'index.html') or die ('open: ' . $!);
 131
 132         print FH head ("yaala $::VERSION", "yaala $::VERSION - Index");
 133         print FH navbar ();
 134
 135         if (scalar (keys (%$::EXTRA)))
 136         {
 137                 print FH "\n<hr>\n<table>\n";
 138                 for (keys (%$::EXTRA))
 139                 {
 140                         my $key = $_;
 141                         my $val = $::EXTRA->{$key};
 142
 143                         print FH qq#  <tr>\n    <th class="top">$key</th>\n    <td>$val</td>\n  </tr>\n#;
 144                 }
 145                 print FH "</table>\n";
 146         }
 147         else
 148         {
 149                 print FH "\n<!-- no \%::EXTRA -->\n";
 150         }
 151
 152         print FH foot ();
 153         close (FH);
 154 }
 155
 156 sub generate_1D_table
 157 {
 158         my $sel = shift;
 159         my $key = shift;
 160
 161         my $do_links = 0;
 162         if (@_) { $do_links = shift; }
 163
 164         my @aggs = @{$sel->[0]};
 165
 166         my @vals = get_values ($sel, $key);
 167         @vals = sort (@vals);
 168
 169         my %grand_total = ();
 170         for (@aggs)
 171         {
 172                 $grand_total{$_} = receive ($sel, $_, {});
 173         }
 174
 175         my $text = "\n<hr>\n";
 176
 177         my $graph_file = generate_graph ($sel, $key);
 178         if ($graph_file)
 179         {
 180                 $text .= qq#<p><img src="$graph_file" width="$GRAPH_WIDTH" height="$GRAPH_HEIGHT" alt="[graph]" /></p>\n#;
 181         }
 182
 183         $text .= "<table>\n  <tr>\n"
 184         .       '    <th colspan="' . (1 + (2 * scalar (@aggs))) . '">'
 185         .       ucfirst ($key) . "</th>\n  </tr>\n";
 186
 187         if (scalar (@aggs) > 1)
 188         {
 189                 $text .= qq#  <tr>\n    <th class="subhdr">Aggregation</th>\n#;
 190                 $text .= qq#    <th colspan="2" class="subhdr"># . ucfirst ($_) . "</th>\n" for (@aggs);
 191                 $text .= "  </tr>\n";
 192         }
 193
 194         for (@vals)
 195         {
 196                 my $val = $_;
 197
 198                 $text .= qq#  <tr>\n    <th class="subhdr">#;
 199                 if ($do_links)
 200                 {
 201                         my $tmpval = $val;
 202                         $tmpval =~ s/\W//g;
 203                         $text .= qq(<a href="#$tmpval">);
 204                 }
 205                 $text .= $val;
 206                 if ($do_links)
 207                 {
 208                         $text .= '</a>';
 209                 }
 210                 $text .= "</th>\n";
 211
 212                 for (@aggs)
 213                 {
 214                         my $agg = $_;
 215                         my $sum = receive ($sel, $agg, {$key => $val});
 216                         my $print_sum = convert ($agg, $sum);
 217
 218                         $text .= qq#</th>\n    <td>$print_sum</td>\n#
 219                         .       "    <td>" . sprintf ("%.1f%%", 100 * $sum / $grand_total{$agg}) . "</td>\n";
 220                 }
 221         }
 222
 223         $text .= qq#  <tr>\n    <th class="subhdr">Total</td>\n#;
 224         for (@aggs)
 225         {
 226                 my $agg = $_;
 227                 my $print_sum = convert ($agg, $grand_total{$agg});
 228
 229                 $text .= qq#    <td class="total">$print_sum</td>\n#
 230                 .       qq#    <td class="total">100.0%</td>\n#
 231         }
 232         $text .= qq#</tr>\n</table>\n#;
 233
 234         return ($text);
 235 }
 236
 237 sub generate_2D_table
 238 {
 239         my $sel = shift;
 240         my $key1 = shift;
 241         my $key2 = shift;
 242
 243         my $text;
 244
 245         my $key3 = '';
 246         my $val3 = '';
 247         if (scalar (@_) >= 2)
 248         {
 249                 $key3 = shift;
 250                 $val3 = shift;
 251         }
 252
 253         my @aggs = @{$sel->[0]};
 254         my $num_aggs = scalar (@aggs);
 255
 256         my @vals1 = get_values ($sel, $key1);
 257         my @vals2 = get_values ($sel, $key2);
 258
 259         @vals1 = sort (@vals1);
 260         @vals2 = sort (@vals2);
 261
 262         my %grand_total = ();
 263         for (@aggs)
 264         {
 265                 my $query = {};
 266                 if ($key3 and $val3)
 267                 {
 268                         $query->{$key3} = $val3;
 269                 }
 270                 $grand_total{$_} = receive ($sel, $_, $query);
 271         }
 272
 273         my $target = '';
 274         if ($val3)
 275         {
 276                 my $tmpval = $val3;
 277                 $tmpval =~ s/\W//g;
 278                 $text = qq#\n<hr id="$tmpval" />\n#;
 279         }
 280         else
 281         {
 282                 $text = qq#\n<hr />\n#;
 283         }
 284
 285         my $graph_file = generate_graph ($sel, $key1, $key3, $val3);
 286         if ($graph_file)
 287         {
 288                 $text .= qq#<p><img src="$graph_file" width="$GRAPH_WIDTH" height="$GRAPH_HEIGHT" alt="[graph]" />\n#;
 289
 290                 $graph_file = generate_graph ($sel, $key2, $key3, $val3);
 291                 $text .= qq#  <img src="$graph_file" width="$GRAPH_WIDTH" height="$GRAPH_HEIGHT" alt="[graph]" /></p>\n#;
 292         }
 293
 294         $text .= qq#<table>\n#;
 295
 296         if ($key3 and $val3)
 297         {
 298                 $text .= "  <caption>$val3</caption>\n";
 299         }
 300
 301         my $agg_column_width = '';
 302         if ($num_aggs > 1)
 303         {
 304                 $agg_column_width = qq# colspan="$num_aggs"#;
 305         }
 306
 307         # first line
 308         $text .= qq#  <tr>\n    <td colspan="2" rowspan="# . ($num_aggs > 1 ? '3' : '2')
 309         . qq#" class="blank"><img src="logo.png" /></td>\n#
 310         . '    <th colspan="' . ($num_aggs * scalar (@vals2)) . qq#"># . ucfirst ($key2) . "</th>\n"
 311         . qq#    <th rowspan="2"$agg_column_width>Total</th>\n#
 312         . qq#    <th rowspan="2"$agg_column_width>Percent</th>\n#
 313         . "  </tr>\n";
 314
 315         # second line
 316         $text .= "  <tr>\n";
 317         for (@vals2)
 318         {
 319                 $text .= qq#    <th class="subhdr"$agg_column_width>$_</th>\n#;
 320         }
 321         $text .= qq#  </tr>\n#;
 322
 323         # third line (if appropriate only)
 324         if ($num_aggs > 1)
 325         {
 326                 $text .= "  <tr>\n";
 327
 328                 my $tmp = join ('', map { qq#    <th class="subhdr">$_</th>\n# } (@aggs));
 329                 $text .= $tmp x (2 + scalar (@vals2));
 330
 331                 $text .= "  </tr>\n";
 332         }
 333         $text .= qq#  <tr>\n    <th rowspan="# . scalar (@vals1)
 334         . qq#"># . ucfirst ($key1) . "</th>\n";
 335
 336         my $this_is_the_first_line = 1;
 337         for (@vals1)
 338         {
 339                 my $val1 = $_;
 340
 341                 $text .= "  <tr>\n" unless ($this_is_the_first_line);
 342                 $this_is_the_first_line = 0;
 343
 344                 $text .= qq#    <th class="subhdr">$val1</th>\n#;
 345
 346                 for (@vals2)
 347                 {
 348                         my $val2 = $_;
 349
 350                         my $query = { $key1 => $val1, $key2 => $val2 };
 351                         if ($key3 and $val3)
 352                         {
 353                                 $query->{$key3} = $val3;
 354                         }
 355
 356                         for (@aggs)
 357                         {
 358                                 my $agg = $_;
 359
 360                                 my $this_val = receive ($sel, $agg, $query);
 361                                 my $print_val = convert ($agg, $this_val);
 362
 363                                 $text .= '    <td>' . ($print_val ? $print_val : '&nbsp;') . "</td>\n";
 364                         }
 365                 }
 366
 367                 my $query = { $key1 => $val1 };
 368                 if ($key3 and $val3)
 369                 {
 370                         $query->{$key3} = $val3;
 371                 }
 372
 373                 my $tmp = '';
 374                 for (@aggs)
 375                 {
 376                         my $this_val = receive ($sel, $_, $query);
 377                         my $print_val = convert ($_, $this_val);
 378
 379                         $text .= '    <td class="total">' . ($print_val ? $print_val : '&nbsp;') . "</td>\n";
 380                         $tmp .= '    <td class="total">'
 381                         .       ($this_val ? sprintf ("%.1f%%", 100 * $this_val / $grand_total{$_}) : '&nbsp;')
 382                         .       "</td>\n";
 383                 }
 384                 $text .= $tmp . "  </tr>\n";
 385         }
 386         # TODO 2003-05-10 13:00
 387         $text .= qq#  <tr>\n    <th colspan="2">Total</th>\n#;
 388         my @percentages = ();
 389         for (@vals2)
 390         {
 391                 my $val2 = $_;
 392
 393                 my $query = { $key2 => $val2 };
 394                 if ($key3 and $val3)
 395                 {
 396                         $query->{$key3} = $val3;
 397                 }
 398
 399                 for (@aggs)
 400                 {
 401                         my $agg = $_;
 402
 403                         my $this_val = receive ($sel, $agg, $query);
 404                         my $print_val = convert ($agg, $this_val);
 405
 406                         $text .= '    <td class="total">' . ($print_val ? $print_val : '&nbsp;') . "</td>\n";
 407
 408                         my $pc = ($this_val ? sprintf ("%.1f%%", 100 * $this_val / $grand_total{$agg}) : '&nbsp;');
 409                         push (@percentages, $pc);
 410                 }
 411         }
 412
 413         for (@aggs)
 414         {
 415                 my $agg = $_;
 416
 417                 my $print_val = convert ($agg, $grand_total{$agg});
 418                 $text .= '    <td class="total">' . ($print_val ? $print_val : '&nbsp;') . "</td>\n";
 419         }
 420
 421         $text .= qq#    <td class="blank"$agg_column_width>&nbsp;</td>\n#
 422         .       qq#  </tr>\n#
 423         .       qq#  <tr>\n#
 424         .       qq#    <th colspan="2">Percent</th>\n#;
 425         $text .= qq#    <td class="total">$_</td>\n# for (@percentages);
 426         $text .= qq#    <td class="blank" colspan="# . (2 * $num_aggs) . qq#">&nbsp;</td>\n#
 427         .       qq#  </tr>\n#
 428         .       qq#</table>\n#;
 429
 430         return ($text);
 431 }