lib/Onis/Html.pm

   1 package Onis::Html;
   2
   3 use strict;
   4 use warnings;
   5 use Fcntl qw/:flock/;
   6 use Exporter;
   7 use Onis::Config qw/get_config/;
   8 use Onis::Language qw/translate/;
   9 use Onis::Data::Core qw#get_channel get_total_lines#;
  10
  11 @Onis::Html::EXPORT_OK = qw/open_file close_file get_filehandle html_escape/;
  12 @Onis::Html::ISA = ('Exporter');
  13
  14 our $fh;
  15 our $time_start = time ();
  16
  17 our $WANT_COLOR = 0;
  18 our $PUBLIC_PAGE = 1;
  19
  20 if (get_config ('color_codes'))
  21 {
  22         my $temp = get_config ('color_codes');
  23         if (($temp eq 'print') or ($temp eq 'true')
  24                         or ($temp eq 'yes')
  25                         or ($temp eq 'on'))
  26         {
  27                 $WANT_COLOR = 1;
  28         }
  29 }
  30 if (get_config ('public_page'))
  31 {
  32         my $temp = get_config ('public_page');
  33
  34         if ($temp =~ m/false|off|no/i)
  35         {
  36                 $PUBLIC_PAGE = 0;
  37         }
  38 }
  39
  40 # `orange' is not a plain html name.
  41 # The color we want is #FFA500
  42 our @mirc_colors = qw/white black navy green red maroon purple orange
  43                         yellow lime teal aqua blue fuchsia gray silver/;
  44
  45 my $VERSION = '$Id: Html.pm,v 1.20 2004/09/16 10:30:20 octo Exp $';
  46 print STDERR $/, __FILE__, ": $VERSION" if ($::DEBUG);
  47
  48 return (1);
  49
  50 sub get_filehandle
  51 {
  52         return ($fh);
  53 }
  54
  55 sub open_file
  56 {
  57         my $file = shift;
  58
  59         if (defined ($fh))
  60         {
  61                 print STDERR $/, __FILE__, ": Not opening file ``$file'': Another file is already open!";
  62                 return (undef);
  63         }
  64
  65         unless (open ($fh, "> $file"))
  66         {
  67                 print STDERR $/, __FILE__, ": Unable to open file ``$file'': $!";
  68                 return (undef);
  69         }
  70
  71         unless (flock ($fh, LOCK_EX))
  72         {
  73                 print STDERR $/, __FILE__, ": Unable to exclusive lock file ``$file'': $!";
  74                 close ($fh);
  75                 return (undef);
  76         }
  77
  78         print_head ();
  79
  80         return ($fh);
  81 }
  82
  83 # Generates the HTML header including the CSS information.
  84 # Doesn't take any arguments
  85 sub print_head
  86 {
  87         my $generated_time = scalar (localtime ($time_start));
  88         my $trans;
  89
  90         my $stylesheet = 'style.css';
  91         if (get_config ('stylesheet'))
  92         {
  93                 $stylesheet = get_config ('stylesheet');
  94         }
  95
  96         my $encoding = 'iso-8859-1';
  97         if (get_config ('encoding'))
  98         {
  99                 $encoding = get_config ('encoding');
 100         }
 101
 102         my $user = 'onis';
 103         if (get_config ('user'))
 104         {
 105                 $user = get_config ('user');
 106         }
 107         elsif (defined ($ENV{'USER'}))
 108         {
 109                 $user = $ENV{'USER'};
 110         }
 111
 112         my $channel = get_channel ();
 113
 114         my @images = get_config ('horizontal_images');
 115         if (!@images)
 116         {
 117                 @images = qw#images/hor0n.png images/hor1n.png images/hor2n.png images/hor3n.png#;
 118         }
 119
 120         $trans = translate ('%s statistics created by %s');
 121         my $title = sprintf ($trans, $channel, $user);
 122
 123
 124         print $fh <<EOF;
 125 <?xml version="1.0" encoding="$encoding"?>
 126 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
 127         "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
 128
 129 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
 130 <head>
 131   <title>$title</title>
 132   <meta http-equiv="Cache-Control" content="public, must-revalidiate" />
 133   <link rel="stylesheet" type="text/css" href="$stylesheet" />
 134 </head>
 135
 136 <body>
 137
 138 <div class="msie_hack">
 139 EOF
 140
 141         $trans = translate ('%s stats by %s');
 142         $title = sprintf ($trans, $channel, $user);
 143
 144         $trans = translate ('Statistics generated on %s');
 145         my $time_msg = sprintf ($trans, $generated_time);
 146
 147         $trans = translate ('Hours');
 148
 149         print $fh <<EOF;
 150 <h1>$title</h1>
 151 <p>$time_msg</p>
 152
 153 <table class="legend">
 154   <tr>
 155     <td><img src="$images[0]" alt="Red"   /><br />$trans 0-5</td>
 156     <td><img src="$images[1]" alt="Green" /><br />$trans 6-11</td>
 157     <td><img src="$images[2]" alt="Blue"  /><br />$trans 12-17</td>
 158     <td><img src="$images[3]" alt="Red"   /><br />$trans 18-24</td>
 159   </tr>
 160 </table>
 161
 162 EOF
 163 }
 164
 165 # this routine adds a box to the end of the html-
 166 # page with onis' homepage URL, the author's name
 167 # and email-address. Feel free to uncomment the
 168 # creation of this box if it's appereance nags
 169 # you..
 170 sub close_file
 171 {
 172         my $runtime = time () - $time_start;
 173         my $now = scalar (localtime ());
 174         my ($total_lines, $lines_this_time) = get_total_lines ();
 175         my $lines_per_sec = 'infinite';
 176
 177         $total_lines ||= 0;
 178         $lines_this_time ||= 0;
 179
 180         my $hp    = translate ("onis' homepage");
 181         my $gen   = translate ('This page was generated <span>on %s</span> <span>with %s</span>');
 182         my $stats = translate ('%u lines processed in %u seconds (%s lines per second, %u lines total)');
 183         my $by    = translate ('onis is written %s <span>by %s</span>');
 184         my $link  = translate ('Get the latest version from %s');
 185
 186         my $lps = translate ('infinite');
 187         if ($runtime)
 188         {
 189                 $lps = sprintf ("%.1f", ($lines_this_time / $runtime));
 190         }
 191
 192         print $fh <<EOF;
 193 </div> <!-- class="msie_hack" -->
 194 <!-- This script is under GPL (GNU public license). You may copy and modify it. -->
 195
 196 <table class="copy">
 197   <tr>
 198 EOF
 199         print  $fh '    <td class="left">';
 200         printf $fh ($gen, $now, "onis $::VERSION (&quot;onis not irc stats&quot;)");
 201         print  $fh "<br />\n      ";
 202         printf $fh ($stats, $lines_this_time, $runtime, $lps, $total_lines);
 203         print  $fh qq#\n    </td>\n    <td class="right">\n      #;
 204         printf $fh ($by, '2000-2005', '<a href="http://verplant.org/">Florian octo Forster</a></span> <span>&lt;octo@<span class="spam">nospam.</span>verplant.org&gt;');
 205         print  $fh qq#<img id="smalllogo" src="http://images.verplant.org/onis-small.png" /># if ($PUBLIC_PAGE);
 206         print  $fh "<br />\n      ";
 207         printf $fh ($link, sprintf (qq#<a href="http://verplant.org/onis/">%s</a>#, $hp));
 208
 209         print $fh <<EOF;
 210
 211     </td>
 212   </tr>
 213 </table>
 214
 215 </body>
 216 </html>
 217 EOF
 218 }
 219
 220 sub html_escape
 221 {
 222         my @retval = ();
 223
 224         foreach (@_)
 225         {
 226                 my $esc = escape_uris ($_);
 227                 push (@retval, $esc);
 228         }
 229
 230         if (wantarray ())
 231         {
 232                 return @retval;
 233         }
 234         else
 235         {
 236                 return join ("\n", @retval);
 237         }
 238 }
 239
 240 sub escape_uris
 241 {
 242         my $text = shift;
 243         my $retval = '';
 244
 245         return ('') if (!defined ($text));
 246
 247         #if ($text =~ m#(?:(?:ftp|https?)://|www\.)[\w\.-]+\.[A-Za-z]{2,4}(?::\d+)?(?:/[\w\d\.\%/-~]+)?(?=\W|$)#i)
 248         if ($text =~ m#(?:(?:ftp|https?)://|www\.)[\w\.-]+\.[A-Za-z]{2,4}(?::\d+)?(?:/[\w\d\.\%\/\-\~]*(?:\?[\+\w\&\%\=]+)?)?(?=\W|$)#i)
 249         {
 250                 my $orig_match = $&;
 251                 my $prematch = $`;
 252                 my $postmatch = $';
 253
 254                 my $match = $orig_match;
 255                 if ($match =~ /^www/i) { $match = 'http://' . $match; }
 256                 if ($match !~ m#://.+/#) { $match .= '/'; }
 257
 258                 if ((length ($orig_match) > 50) and ($orig_match =~ m#^http://#))
 259                 {
 260                         $orig_match =~ s#^http://##;
 261                 }
 262                 if (length ($orig_match) > 50)
 263                 {
 264                         my $len = length ($orig_match) - 47;
 265                         substr ($orig_match, 47, $len, '...');
 266                 }
 267
 268                 $retval = escape_normal ($prematch);
 269                 $retval .= qq(<a href="$match">$orig_match</a>);
 270                 $retval .= escape_uris ($postmatch);
 271         }
 272         else
 273         {
 274                 $retval = escape_normal ($text);
 275         }
 276
 277         return ($retval);
 278 }
 279
 280 sub escape_normal
 281 {
 282         my $text = shift;
 283
 284         return ('') if (!defined ($text));
 285
 286         $text =~ s/\&/\&amp;/g;
 287         $text =~ s/"/\&quot;/g;
 288         $text =~ s/</\&lt;/g;
 289         $text =~ s/>/\&gt;/g;
 290
 291         # german umlauts
 292         $text =~ s/ä/\&auml;/g;
 293         $text =~ s/ö/\&ouml;/g;
 294         $text =~ s/ü/\&uuml;/g;
 295         $text =~ s/Ä/\&Auml;/g;
 296         $text =~ s/Ü/\&Ouml;/g;
 297         $text =~ s/Ö/\&Uuml;/g;
 298         $text =~ s/ß/\&szlig;/g;
 299
 300         if ($WANT_COLOR)
 301         {
 302                 $text = find_colors ($text);
 303         }
 304         else
 305         {
 306                 $text =~ s/[\cB\c_\cV\cO]|\cC(?:\d+(?:,\d+)?)?//g;
 307         }
 308
 309         return ($text);
 310 }
 311
 312 sub find_colors
 313 {
 314         my $string = shift;
 315         my $open_spans = 0;
 316
 317         my $code_ref;
 318
 319         my %flags =
 320         (
 321                 span_open       =>      0,
 322                 fg_color        =>      -1,
 323                 bg_color        =>      -1,
 324                 bold            =>      0,
 325                 underline       =>      0,
 326                 'reverse'       =>      0
 327         );
 328
 329         while ($string =~ m/([\cB\c_\cV\cO])|(\cC)(?:(\d+)(?:,(\d+))?)?/g)
 330         {
 331                 my $controlchar = $1 ? $1 : $2;
 332                 my $fg = defined ($3) ? $3 : -1;
 333                 my $bg = defined ($4) ? $4 : -1;
 334
 335                 my $prematch  = $`;
 336                 my $postmatch = $';
 337
 338                 my $newspan = "";
 339
 340                 # Close open spans first
 341                 if ($flags{'span_open'})
 342                 {
 343                         $newspan .= "</span>";
 344                         $flags{'span_open'} = 0;
 345                 }
 346
 347                 # To catch `\cC' without anything following..
 348                 if (($controlchar eq "\cC") and ($fg == -1) and ($bg == -1))
 349                 {
 350                         $flags{'fg_color'} = -1;
 351                         $flags{'bg_color'} = -1;
 352                 }
 353                 elsif ($controlchar eq "\cC")
 354                 {
 355                         if ($fg != -1)
 356                         {
 357                                 $flags{'fg_color'} = $fg % scalar (@mirc_colors);
 358                         }
 359                         if ($bg != -1)
 360                         {
 361                                 $flags{'bg_color'} = $bg % scalar (@mirc_colors);
 362                         }
 363                 }
 364                 elsif ($controlchar eq "\cB")
 365                 {
 366                         $flags{'bold'} = 1 - $flags{'bold'};
 367                 }
 368                 elsif ($controlchar eq "\c_")
 369                 {
 370                         $flags{'underline'} = 1 - $flags{'underline'};
 371                 }
 372                 elsif ($controlchar eq "\cV")
 373                 {
 374                         $flags{'reverse'} = 1 - $flags{'reverse'};
 375                 }
 376                 # reset
 377                 elsif ($controlchar eq "\cO")
 378                 {
 379                         $flags{'fg_color'} = -1;
 380                         $flags{'bg_color'} = -1;
 381                         $flags{'bold'} = 0;
 382                         $flags{'underline'} = 0;
 383                         $flags{'reverse'} = 0;
 384                 }
 385
 386                 # build the new span-tag
 387                 if (($flags{'fg_color'} != -1) || ($flags{'bg_color'} != -1)
 388                         || $flags{'bold'} || $flags{'underline'})
 389                 {
 390                         my $fg = $flags{'fg_color'};
 391                         my $bg = $flags{'bg_color'};
 392                         my @style = ();
 393
 394                         if ($flags{'reverse'} and ($bg != -1))
 395                         {
 396                                 $fg = $flags{'bg_color'};
 397                                 $bg = $flags{'fg_color'};
 398                         }
 399
 400                         if ($fg != -1)
 401                         {
 402                                 push (@style, 'color: ' . $mirc_colors[$fg] . ';');
 403                         }
 404                         if ($bg != -1)
 405                         {
 406                                 push (@style, 'background-color: ' . $mirc_colors[$bg] . ';');
 407                         }
 408                         if ($flags{'bold'})
 409                         {
 410                                 push (@style, 'font-weight: bold;');
 411                         }
 412                         if ($flags{'underline'})
 413                         {
 414                                 push (@style, 'text-decoration: underline;');
 415                         }
 416
 417                         $newspan .= '<span style="' . join (' ', @style) . '">';
 418                         $flags{'span_open'} = 1;
 419                 }
 420
 421                 $string = $prematch . $newspan . $postmatch;
 422         }
 423
 424         if ($flags{'span_open'})
 425         {
 426                 $string .= "</span>";
 427                 $flags{'span_open'} = 0;
 428         }
 429
 430         return ($string);
 431 }