lib/Yaala/Report/Classic.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: Classic.pm,v 1.10 2003/12/07 14:53:30 octo Exp $';
  19 print STDERR $/, __FILE__, ": $VERSION" if ($::DEBUG);
  20
  21 our $skip_empty = 1;
  22 if (get_config ('classic_skip_empty'))
  23 {
  24         my $conf = lc (get_config ('classic_skip_empty'));
  25         if ($conf eq 'no' or $conf eq 'false') { $skip_empty = 0; }
  26 }
  27
  28 return (1);
  29
  30 sub generate
  31 {
  32         for (@$SELECTS)
  33         {
  34                 my $sel = $_;
  35                 my @keys = @{$sel->[1]};
  36
  37                 generate_sub_index ($sel);
  38
  39                 for (@keys)
  40                 {
  41                         my $key = $_;
  42                         generate_sub_page ($sel, $key);
  43                 }
  44         }
  45
  46         generate_index_page ();
  47
  48         return (1);
  49 }
  50
  51 sub generate_sub_page
  52 {
  53         my $sel = shift;
  54         my $key = shift;
  55
  56         my @vals = get_values ($sel, $key);
  57
  58         my $filename = get_filename ($sel);
  59         $filename =~ s/\.html$/__$key.html/;
  60         my $title = get_title ($sel);
  61
  62         open (FH, '> ' . $OUTPUTDIR . $filename) or die ('open: ' . $!);
  63
  64         print FH head ($title, $title);
  65         print FH '<h2>', ucfirst ($key), "</h2>\n";
  66         print FH qq#<a id="top_of_page"></a>\n#;
  67         print FH navbar ($sel);
  68         print FH own_navbar ($sel, $key);
  69
  70         my $graph_file = generate_graph ($sel, $key);
  71         if ($graph_file)
  72         {
  73                 print FH qq#<p><img src="$graph_file" width="$GRAPH_WIDTH" #,
  74                 qq#height="$GRAPH_HEIGHT" alt="[graph]" /></p>\n#;
  75         }
  76
  77         for (sort (@vals))
  78         {
  79                 my $val = $_;
  80                 print FH generate_table ($sel, $key, $val);
  81         }
  82
  83         print FH foot ();
  84         close (FH);
  85 }
  86
  87 sub generate_sub_index
  88 {
  89         my $sel = shift;
  90
  91         my $filename = get_filename ($sel);
  92         my $title = get_title ($sel);
  93
  94         open (FH, '> ' . $OUTPUTDIR . $filename) or die ('open: ' . $!);
  95
  96         print FH head ($title, $title);
  97         print FH navbar ($sel);
  98         print FH own_navbar ($sel);
  99
 100         print FH "<table>\n";
 101         for (@{$sel->[1]})
 102         {
 103                 my $key = $_;
 104                 my @vals = get_values ($sel, $key);
 105                 my $num_vals = scalar (@vals);
 106
 107                 print FH "  <tr>\n    <th>", ucfirst ($key), "</th>\n",
 108                 "    <td>$num_vals entr", ($num_vals == 1 ? 'y' : 'ies'),
 109                 "</td>\n  </tr>\n";
 110         }
 111         print FH "</table>\n\n";
 112
 113         print FH foot ();
 114         close (FH);
 115 }
 116
 117 sub generate_index_page
 118 {
 119         open (FH, '> ' . $OUTPUTDIR . 'index.html') or die ('open: ' . $!);
 120
 121         print FH head ("yaala $::VERSION", "yaala $::VERSION - Index");
 122         print FH navbar ();
 123
 124         if (scalar (keys (%$::EXTRA)))
 125         {
 126                 print FH "\n<hr>\n<table>\n";
 127                 for (keys (%$::EXTRA))
 128                 {
 129                         my $key = $_;
 130                         my $val = $::EXTRA->{$key};
 131
 132                         print FH qq#  <tr>\n    <th class="top">$key</th>\n    <td>$val</td>\n  </tr>\n#;
 133                 }
 134                 print FH "</table>\n";
 135         }
 136         else
 137         {
 138                 print FH "\n<!-- no \%::EXTRA -->\n";
 139         }
 140
 141         print FH foot ();
 142         close (FH);
 143 }
 144
 145 sub generate_table
 146 {
 147         my $sel = shift;
 148         my $key = shift;
 149         my $val = shift;
 150
 151         my @aggs = @{$sel->[0]};
 152         my $num_aggs = scalar (@aggs);
 153
 154         my @keys = grep { $_ ne $key } (@{$sel->[1]});
 155         @keys = sort (@keys);
 156
 157
 158         my $link_val = $val;
 159         $link_val =~ s/\W//g;
 160
 161         my $text = qq#\n<hr />\n<table id="$link_val">\n  <tr>\n#;
 162         $text .= '    <th colspan="' . (2 + (2 * $num_aggs)) . '">' . ucfirst ($val) . "</th>\n  </tr>\n";
 163         $text .= qq#  <tr>\n    <th class="subhdr">Field</th>\n#
 164         .       qq#    <th class="subhdr">Value</th>\n#;
 165
 166         my %grand_total = ();
 167         for (@aggs)
 168         {
 169                 $text .= qq#    <th class="subhdr"># . ucfirst ($_) . "</th>\n"
 170                 .       qq#    <th class="subhdr">Percent</th>\n#;
 171
 172                 $grand_total{$_} = receive ($sel, $_, {$key => $val});
 173         }
 174         $text .= "  </tr>\n";
 175
 176         for (@keys)
 177         {
 178                 my $second_key = $_;
 179                 my @second_vals = get_values ($sel, $second_key);
 180
 181                 my $tmp_text = '';
 182                 my $first_line = 1;
 183                 my %sub_total = ();
 184
 185                 my $num_vals = scalar (@second_vals);
 186
 187                 for (sort (@second_vals))
 188                 {
 189                         my $this_val = $_;
 190                         my $skipped_cells = 0;
 191                         my $tmp_text2 = '';
 192
 193                         if (!$first_line) { $tmp_text2 = "  <tr>\n"; }
 194                         $tmp_text2 .= qq#    <td>$this_val</td>\n#;
 195
 196                         for (@aggs)
 197                         {
 198                                 my $agg = $_;
 199                                 my $sum = 0;
 200
 201                                 if (!defined ($sub_total{$agg})
 202                                                 or ($sub_total{$agg} != $grand_total{$agg}))
 203                                 {
 204                                         $sum = receive ($sel, $agg, {$key => $val, $second_key => $this_val});
 205                                         $sub_total{$agg} += $sum;
 206                                 }
 207
 208                                 if (!$sum and $skip_empty)
 209                                 {
 210                                         $skipped_cells++;
 211                                 }
 212
 213                                 my $print_sum = convert ($agg, $sum);
 214
 215                                 my $percent = ($sum ? sprintf ("%.1f%%", 100 * $sum / $grand_total{$agg}) : '&nbsp;');
 216
 217                                 $tmp_text2 .= "    <td>"
 218                                 .       ($print_sum ? $print_sum : '&nbsp;' )
 219                                 .       qq#</td>\n#
 220                                 .       qq#    <td>$percent</td>\n#;
 221                         }
 222
 223                         $tmp_text2 .= "  </tr>\n";
 224
 225                         if ($skipped_cells == $num_aggs)
 226                         {
 227                                 $num_vals--;
 228                         }
 229                         else
 230                         {
 231                                 $first_line = 0;
 232                                 $tmp_text .= $tmp_text2;
 233                         }
 234                 }
 235
 236                 $text .= qq#  <tr>\n    <th class="subhdr"#
 237                 . ($num_vals > 1 ? qq# rowspan="$num_vals"# : '')
 238                 . '>' . ucfirst ($second_key) . "</th>\n"
 239                 . $tmp_text;
 240         }
 241
 242         $text .= qq#  <tr>\n    <th class="subhdr">Total</th>\n#
 243         .       qq#    <td class="total">&nbsp;</td>\n#;
 244         for (@aggs)
 245         {
 246                 my $print_sum = convert ($_, $grand_total{$_});
 247
 248                 $text .= qq#    <td class="total">$print_sum</td>\n#
 249                 .       qq#    <td class="total">100.0%</td>\n#;
 250         }
 251         $text .= qq#  </tr>\n</table>\n#
 252         .       qq(<p>[&nbsp;<a href="#top_of_page">top</a>&nbsp;]</p>\n);
 253
 254         return ($text);
 255 }
 256
 257 sub own_navbar
 258 {
 259         my $sel = shift;
 260         my $key = shift;
 261
 262         if (!defined ($key)) { $key = ''; }
 263
 264         my $base_filename = get_filename ($sel);
 265         my $text = qq#<p class="navbar">\n#;
 266
 267         for (@{$sel->[1]})
 268         {
 269                 my $this_key = $_;
 270                 my $this_filename = $base_filename;
 271                 $this_filename =~ s/\.html$/__$this_key.html/;
 272
 273                 if ($this_key eq $key)
 274                 {
 275                         $text .= '  <span>[ ' . ucfirst ($key) . " ]</span>\n";
 276                 }
 277                 else
 278                 {
 279                         $text .= qq#  <span>[ <a href="$this_filename"># . ucfirst ($this_key) . "</a> ]</span>\n";
 280                 }
 281         }
 282
 283         $text .= "</p>\n";
 284
 285         if ($key)
 286         {
 287                 my @vals = get_values ($sel, $key);
 288
 289                 $text .= qq#<p class="navbar">\n#;
 290                 for (sort (@vals))
 291                 {
 292                         my $link_val = $_;
 293                         my $print_val = convert ($key, $_);
 294                         $link_val =~ s/\W//g;
 295
 296                         $text .= qq(  <span>[ <a href="#$link_val">$print_val</a> ]</span>\n);
 297                 }
 298                 $text .= "</p>\n";
 299         }
 300
 301         return ($text);
 302 }