lib/Yaala/Html.pm

   1 package Yaala::Html;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Exporter;
   7 use Yaala::Config qw#get_config#;
   8 use Yaala::Data::Setup qw#$SELECTS#;
   9
  10 @Yaala::Html::EXPORT_OK = qw(escape head foot navbar get_filename get_title);
  11 @Yaala::Html::ISA = ('Exporter');
  12
  13 =head1 Html.pm
  14
  15 A set of utilities used by report modules.
  16
  17 =cut
  18
  19 my $VERSION = '$Id: Html.pm,v 1.8 2003/12/07 14:52:02 octo Exp octo $';
  20 print STDERR $/, __FILE__, ": $VERSION" if ($::DEBUG);
  21
  22 return (1);
  23
  24 # NB: preserves all &foo; to allow inclusion of strange characters
  25 #     returns list
  26 sub escape
  27 {
  28         my @esc = map
  29         {
  30                 s/</&lt;/g;
  31                 s/>/&gt;/g;
  32                 s/"/&quot;/g;
  33                 s/\s{2,}/&nbsp;/g;
  34                 $_;
  35         } (@_);
  36
  37         if (wantarray ())
  38         {
  39                 return (@esc);
  40         }
  41         else
  42         {
  43                 return (join ('', @esc));
  44         }
  45 }
  46
  47 # generates only common header - with title and head.
  48 sub head
  49 {
  50         my ($title, $header) = @_;
  51         my $text;
  52         my $charset = get_config ('html_charset');
  53         my $stylesheet = get_config ('html_stylesheet');
  54
  55         if (!defined ($charset) or !$charset) { $charset = 'iso-8859-1'; }
  56         if (!defined ($stylesheet) or !$stylesheet) { $stylesheet = 'style.css'; }
  57
  58         $text = qq#<?xml version="1.0" encoding="$charset"?>\n#
  59         .       qq#<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"\n#
  60         .       qq#\t"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">\n#
  61         .       qq#<html>\n<head>\n#;
  62
  63         if ($stylesheet)
  64         {
  65                 $text .= qq#  <link rel="stylesheet" type="text/css" #
  66                 .       qq#href="$stylesheet" />\n#;
  67         }
  68
  69         $text .= "  <title>$title</title>\n"
  70         .       qq#  <meta name="robots" value="noindex, nofollow" />\n#
  71         .       "</head>\n\n"
  72         .       "<body>\n";
  73
  74         $text .= qq#<h1><img src="logo.png" /> $header</h1>\n# if $header;
  75         return $text;
  76 }
  77
  78 sub foot
  79 {
  80         my ($a, $e);
  81         my $text = "<hr />\n"
  82         .       qq#<p id="footer">Generated by <a href="$::HOMEPAGE">$::NAME $::VERSION</a>, #
  83         .       scalar (localtime ())
  84         .       "</p>\n";
  85
  86         $text .= "\n</body>\n</html>\n";
  87         return $text;
  88 }
  89
  90 sub navbar
  91 {
  92         my $sel = shift;
  93         my $text = qq#<p class="navbar">\n#;
  94
  95         if (defined ($sel) and ref ($sel))
  96         {
  97                 $text .= qq#  <span>[ <a href="index.html">General</a> ]</span>\n#;
  98         }
  99         else
 100         {
 101                 $text .= qq#  <span>[ General ]</span>\n#;
 102                 $sel = '';
 103         }
 104
 105         for (@$SELECTS)
 106         {
 107                 my $this_sel = $_;
 108                 my $title = get_title ($this_sel);
 109
 110                 if ("$this_sel" eq "$sel")
 111                 {
 112                         $text .= qq#  <span>[ $title ]</span>\n#;
 113                 }
 114                 else
 115                 {
 116                         my $filename = get_filename ($this_sel);
 117                         $text .= qq#  <span>[ <a href="$filename">$title</a> ]</span>\n#;
 118                 }
 119         }
 120
 121         $text .= "</p>\n\n";
 122         return ($text);
 123 }
 124
 125 sub get_filename
 126 {
 127         my $sel = shift;
 128
 129         my $aggs = join ('-', @{$sel->[0]});
 130         my $flds = join ('-', @{$sel->[1]});
 131
 132         my $filename = $aggs . '_BY_' . $flds;
 133
 134         my %sign_names =
 135         (
 136                 '=='    => 'eq',
 137                 'eq'    => 'eq',
 138                 '>='    => 'ge',
 139                 '<='    => 'le',
 140                 '!='    => 'ne',
 141                 '=~'    => 're',
 142                 '!~'    => 'nre',
 143                 '<'     => 'lt',
 144                 '>'     => 'gt'
 145         );
 146
 147         if (scalar (@{$sel->[2]}))
 148         {
 149                 my @where = ();
 150                 for (@{$sel->[2]})
 151                 {
 152                         my ($key, $op, $val) = @$_;
 153                         $val =~ s/\W//g;
 154
 155                         $op = $sign_names{$op} if (defined ($sign_names{$op}));
 156                         push (@where, join ('-', ($key, $op, $val)));
 157                 }
 158
 159                 $filename .= '_WHERE_' . join ('_AND_', @where);
 160         }
 161
 162         $filename .= '.html';
 163
 164         return ($filename);
 165 }
 166
 167 sub get_title
 168 {
 169         my $sel = shift;
 170
 171         my @aggs = map { ucfirst ($_) } (@{$sel->[0]});
 172         my @flds = map { ucfirst ($_) } (@{$sel->[1]});
 173
 174         my $title = my_join (@aggs) . ' by ' . my_join (@flds);
 175
 176         if (scalar (@{$sel->[2]}))
 177         {
 178                 $title .= ' where ';
 179                 my @wheres = map
 180                 {
 181                         ucfirst ($_->[0]) . ' '
 182                         . $_->[1]
 183                         . ' "' . $_->[2] . '"'
 184                 } (@{$sel->[2]});
 185
 186                 $title .= my_join (@wheres);
 187         }
 188
 189         ($title) = escape ($title);
 190         return ($title);
 191 }
 192
 193 sub my_join
 194 {
 195         my @all = @_;
 196         my $last = pop (@all);
 197
 198         return ($last) unless (@all);
 199
 200         my $retval = join (', ', @all) . " and $last";
 201
 202         return ($retval);
 203 }