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 = get_total_lines () || 0;
 175         my $lines_per_sec = 'infinite';
 176
 177         my $hp    = translate ("onis' homepage");
 178         my $gen   = translate ('This page was generated <span>on %s</span> <span>with %s</span>');
 179         my $stats = translate ('%u lines processed in %u seconds (%s lines per second)');
 180         my $by    = translate ('onis is written %s <span>by %s</span>');
 181         my $link  = translate ('Get the latest version from %s');
 182
 183         my $lps = translate ('infinite');
 184         if ($runtime)
 185         {
 186                 $lps = sprintf ("%.1f", ($total_lines / $runtime));
 187         }
 188
 189         print $fh <<EOF;
 190 </div> <!-- class="msie_hack" -->
 191 <!-- This script is under GPL (GNU public license). You may copy and modify it. -->
 192
 193 <table class="copy">
 194   <tr>
 195 EOF
 196         print  $fh '    <td class="left">';
 197         printf $fh ($gen, $now, "onis $::VERSION (&quot;onis not irc stats&quot;)");
 198         print  $fh "<br />\n      ";
 199         printf $fh ($stats, $total_lines, $runtime, $lps);
 200         print  $fh qq#\n    </td>\n    <td class="right">\n      #;
 201         printf $fh ($by, '2000-2004', '<a href="http://verplant.org/">Florian octo Forster</a></span> <span>&lt;octo@<span class="spam">nospam.</span>verplant.org&gt;');
 202         print  $fh qq#<img id="smalllogo" src="http://images.verplant.org/onis-small.png" /># if ($PUBLIC_PAGE);
 203         print  $fh "<br />\n      ";
 204         printf $fh ($link, sprintf (qq#<a href="http://verplant.org/onis/">%s</a>#, $hp));
 205
 206         print $fh <<EOF;
 207
 208     </td>
 209   </tr>
 210 </table>
 211
 212 </body>
 213 </html>
 214 EOF
 215 }
 216
 217 sub html_escape
 218 {
 219         my @retval = ();
 220
 221         foreach (@_)
 222         {
 223                 my $esc = escape_uris ($_);
 224                 push (@retval, $esc);
 225         }
 226
 227         if (wantarray ())
 228         {
 229                 return @retval;
 230         }
 231         else
 232         {
 233                 return join ("\n", @retval);
 234         }
 235 }
 236
 237 sub escape_uris
 238 {
 239         my $text = shift;
 240         my $retval = '';
 241
 242         return ('') if (!defined ($text));
 243
 244         #if ($text =~ m#(?:(?:ftp|https?)://|www\.)[\w\.-]+\.[A-Za-z]{2,4}(?::\d+)?(?:/[\w\d\.\%/-~]+)?(?=\W|$)#i)
 245         if ($text =~ m#(?:(?:ftp|https?)://|www\.)[\w\.-]+\.[A-Za-z]{2,4}(?::\d+)?(?:/[\w\d\.\%\/\-\~]*(?:\?[\+\w\&\%\=]+)?)?(?=\W|$)#i)
 246         {
 247                 my $orig_match = $&;
 248                 my $prematch = $`;
 249                 my $postmatch = $';
 250
 251                 my $match = $orig_match;
 252                 if ($match =~ /^www/i) { $match = 'http://' . $match; }
 253                 if ($match !~ m#://.+/#) { $match .= '/'; }
 254
 255                 if ((length ($orig_match) > 50) and ($orig_match =~ m#^http://#))
 256                 {
 257                         $orig_match =~ s#^http://##;
 258                 }
 259                 if (length ($orig_match) > 50)
 260                 {
 261                         my $len = length ($orig_match) - 47;
 262                         substr ($orig_match, 47, $len, '...');
 263                 }
 264
 265                 $retval = escape_normal ($prematch);
 266                 $retval .= qq(<a href="$match">$orig_match</a>);
 267                 $retval .= escape_uris ($postmatch);
 268         }
 269         else
 270         {
 271                 $retval = escape_normal ($text);
 272         }
 273
 274         return ($retval);
 275 }
 276
 277 sub escape_normal
 278 {
 279         my $text = shift;
 280
 281         return ('') if (!defined ($text));
 282
 283         $text =~ s/\&/\&amp;/g;
 284         $text =~ s/"/\&quot;/g;
 285         $text =~ s/</\&lt;/g;
 286         $text =~ s/>/\&gt;/g;
 287
 288         # german umlauts
 289         $text =~ s/ä/\&auml;/g;
 290         $text =~ s/ö/\&ouml;/g;
 291         $text =~ s/ü/\&uuml;/g;
 292         $text =~ s/Ä/\&Auml;/g;
 293         $text =~ s/Ü/\&Ouml;/g;
 294         $text =~ s/Ö/\&Uuml;/g;
 295         $text =~ s/ß/\&szlig;/g;
 296
 297         if ($WANT_COLOR)
 298         {
 299                 $text = find_colors ($text);
 300         }
 301         else
 302         {
 303                 $text =~ s/[\cB\c_\cV\cO]|\cC(?:\d+(?:,\d+)?)?//g;
 304         }
 305
 306         return ($text);
 307 }
 308
 309 sub find_colors
 310 {
 311         my $string = shift;
 312         my $open_spans = 0;
 313
 314         my $code_ref;
 315
 316         my %flags =
 317         (
 318                 span_open       =>      0,
 319                 fg_color        =>      -1,
 320                 bg_color        =>      -1,
 321                 bold            =>      0,
 322                 underline       =>      0,
 323                 'reverse'       =>      0
 324         );
 325
 326         while ($string =~ m/([\cB\c_\cV\cO])|(\cC)(?:(\d+)(?:,(\d+))?)?/g)
 327         {
 328                 my $controlchar = $1 ? $1 : $2;
 329                 my $fg = defined ($3) ? $3 : -1;
 330                 my $bg = defined ($4) ? $4 : -1;
 331
 332                 my $prematch  = $`;
 333                 my $postmatch = $';
 334
 335                 my $newspan = "";
 336
 337                 # Close open spans first
 338                 if ($flags{'span_open'})
 339                 {
 340                         $newspan .= "</span>";
 341                         $flags{'span_open'} = 0;
 342                 }
 343
 344                 # To catch `\cC' without anything following..
 345                 if (($controlchar eq "\cC") and ($fg == -1) and ($bg == -1))
 346                 {
 347                         $flags{'fg_color'} = -1;
 348                         $flags{'bg_color'} = -1;
 349                 }
 350                 elsif ($controlchar eq "\cC")
 351                 {
 352                         if ($fg != -1)
 353                         {
 354                                 $flags{'fg_color'} = $fg % scalar (@mirc_colors);
 355                         }
 356                         if ($bg != -1)
 357                         {
 358                                 $flags{'bg_color'} = $bg % scalar (@mirc_colors);
 359                         }
 360                 }
 361                 elsif ($controlchar eq "\cB")
 362                 {
 363                         $flags{'bold'} = 1 - $flags{'bold'};
 364                 }
 365                 elsif ($controlchar eq "\c_")
 366                 {
 367                         $flags{'underline'} = 1 - $flags{'underline'};
 368                 }
 369                 elsif ($controlchar eq "\cV")
 370                 {
 371                         $flags{'reverse'} = 1 - $flags{'reverse'};
 372                 }
 373                 # reset
 374                 elsif ($controlchar eq "\cO")
 375                 {
 376                         $flags{'fg_color'} = -1;
 377                         $flags{'bg_color'} = -1;
 378                         $flags{'bold'} = 0;
 379                         $flags{'underline'} = 0;
 380                         $flags{'reverse'} = 0;
 381                 }
 382
 383                 # build the new span-tag
 384                 if (($flags{'fg_color'} != -1) || ($flags{'bg_color'} != -1)
 385                         || $flags{'bold'} || $flags{'underline'})
 386                 {
 387                         my $fg = $flags{'fg_color'};
 388                         my $bg = $flags{'bg_color'};
 389                         my @style = ();
 390
 391                         if ($flags{'reverse'} and ($bg != -1))
 392                         {
 393                                 $fg = $flags{'bg_color'};
 394                                 $bg = $flags{'fg_color'};
 395                         }
 396
 397                         if ($fg != -1)
 398                         {
 399                                 push (@style, 'color: ' . $mirc_colors[$fg] . ';');
 400                         }
 401                         if ($bg != -1)
 402                         {
 403                                 push (@style, 'background-color: ' . $mirc_colors[$bg] . ';');
 404                         }
 405                         if ($flags{'bold'})
 406                         {
 407                                 push (@style, 'font-weight: bold;');
 408                         }
 409                         if ($flags{'underline'})
 410                         {
 411                                 push (@style, 'text-decoration: underline;');
 412                         }
 413
 414                         $newspan .= '<span style="' . join (' ', @style) . '">';
 415                         $flags{'span_open'} = 1;
 416                 }
 417
 418                 $string = $prematch . $newspan . $postmatch;
 419         }
 420
 421         if ($flags{'span_open'})
 422         {
 423                 $string .= "</span>";
 424                 $flags{'span_open'} = 0;
 425         }
 426
 427         return ($string);
 428 }