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 =head1 NAME
  12
  13 Onis::Html - Low level page generation stuff..
  14
  15 =cut
  16
  17 @Onis::Html::EXPORT_OK = qw/open_file close_file get_filehandle html_escape/;
  18 @Onis::Html::ISA = ('Exporter');
  19
  20 our $fh;
  21 our $time_start = time ();
  22
  23 =head1 CONFIGURATION OPTIONS
  24
  25 =over 4
  26
  27 =item B<color_codes>: I<false>;
  28
  29 Wether or not to print the color codes (introduced by mIRC, used by idiots and
  30 ignored by the rest) in the generated HTML-file. Of course this defaults to not
  31 print the codes..
  32
  33 =cut
  34
  35 our $WantColor = 0;
  36 if (get_config ('color_codes'))
  37 {
  38         my $temp = get_config ('color_codes');
  39         if (($temp eq 'print') or ($temp eq 'true')
  40                         or ($temp eq 'yes')
  41                         or ($temp eq 'on'))
  42         {
  43                 $WantColor = 1;
  44         }
  45 }
  46
  47 =item B<public_page>: I<true>;
  48
  49 Wether or not this is a public page. Public pages may be linked on the onis
  50 homepage at some point in the fututre..
  51
  52 =cut
  53
  54 our $PublicPage = 1;
  55 if (get_config ('public_page'))
  56 {
  57         my $temp = get_config ('public_page');
  58
  59         if ($temp =~ m/false|off|no/i)
  60         {
  61                 $PublicPage = 0;
  62         }
  63 }
  64
  65 =item B<stylesheet>: I<style.css>;
  66
  67 Sets the stylesheet to use. This is included in the HTML-file as-is, so you
  68 have to take care of absolute/relative paths yourself..
  69
  70 =cut
  71
  72 our $Stylesheet = 'style.css';
  73 if (get_config ('stylesheet'))
  74 {
  75         $Stylesheet = get_config ('stylesheet');
  76 }
  77
  78 =item B<encoding>: I<iso-8859-1>;
  79
  80 Sets the encoding to include in the HTML-file. If you don't know what this is,
  81 don't change it..
  82
  83 =cut
  84
  85 our $Encoding = 'iso-8859-1';
  86 if (get_config ('encoding'))
  87 {
  88         $Encoding = get_config ('encoding');
  89 }
  90
  91 =item B<user>: I<onis>;
  92
  93 Sets the user that created the page. Defaults to the environment variable
  94 B<USER> or "onis", if it is not set.
  95
  96 =cut
  97
  98 our $User = 'onis';
  99 if (get_config ('user'))
 100 {
 101         $User = get_config ('user');
 102 }
 103 elsif (defined ($ENV{'USER'}))
 104 {
 105         $User = $ENV{'USER'};
 106 }
 107
 108 =back
 109
 110 =cut
 111
 112 # `orange' is not a plain html name.
 113 # The color we want is #FFA500
 114 our @mirc_colors = qw/white black navy green red maroon purple orange
 115                         yellow lime teal aqua blue fuchsia gray silver/;
 116
 117 my $VERSION = '$Id$';
 118 print STDERR $/, __FILE__, ": $VERSION" if ($::DEBUG);
 119
 120 return (1);
 121
 122 =head1 EXPORTED FUNCTIONS
 123
 124 =over 4
 125
 126 =item B<get_filehandle> ()
 127
 128 Returns the filehandle of the output file or undef, if B<open_file> has not
 129 been called yet.
 130
 131 =cut
 132
 133 sub get_filehandle
 134 {
 135         return ($fh);
 136 }
 137
 138 =item B<open_file> (I<$filename>)
 139
 140 Opens the file I<$filename> if no file is open at this point. The file is
 141 exclusively locked and the filehandle stored in the module. The HTML-header is
 142 printed to the file and the filehandle is returned. You can get another
 143 reference by calling B<get_filehandle>.
 144
 145 =cut
 146
 147 sub open_file
 148 {
 149         my $file = shift;
 150
 151         if (defined ($fh))
 152         {
 153                 print STDERR $/, __FILE__, ": Not opening file ``$file'': Another file is already open!";
 154                 return (undef);
 155         }
 156
 157         unless (open ($fh, "> $file"))
 158         {
 159                 print STDERR $/, __FILE__, ": Unable to open file ``$file'': $!";
 160                 return (undef);
 161         }
 162
 163         unless (flock ($fh, LOCK_EX))
 164         {
 165                 print STDERR $/, __FILE__, ": Unable to exclusive lock file ``$file'': $!";
 166                 close ($fh);
 167                 return (undef);
 168         }
 169
 170         print_head ();
 171
 172         return ($fh);
 173 }
 174
 175 # Generates the HTML header including the CSS information.
 176 # Doesn't take any arguments
 177 sub print_head
 178 {
 179         my $generated_time = scalar (localtime ($time_start));
 180         my $trans;
 181
 182         my $channel = get_channel ();
 183
 184         my @images = get_config ('horizontal_images');
 185         if (!@images)
 186         {
 187                 @images = qw#images/hor0n.png images/hor1n.png images/hor2n.png images/hor3n.png#;
 188         }
 189
 190         $trans = translate ('%s statistics created by %s');
 191         my $title = sprintf ($trans, $channel, $User);
 192
 193
 194         print $fh <<EOF;
 195 <?xml version="1.0" encoding="$Encoding"?>
 196 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
 197         "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
 198
 199 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
 200 <head>
 201   <title>$title</title>
 202   <meta http-equiv="Cache-Control" content="public, must-revalidiate" />
 203   <link rel="stylesheet" type="text/css" href="$Stylesheet" />
 204 </head>
 205
 206 <body>
 207
 208 <div class="msie_hack">
 209 EOF
 210
 211         $trans = translate ('%s stats by %s');
 212         $title = sprintf ($trans, $channel, $User);
 213
 214         $trans = translate ('Statistics generated on %s');
 215         my $time_msg = sprintf ($trans, $generated_time);
 216
 217         $trans = translate ('Hours');
 218
 219         print $fh <<EOF;
 220 <h1>$title</h1>
 221 <p>$time_msg</p>
 222
 223 <table class="legend">
 224   <tr>
 225     <td><img src="$images[0]" alt="Red"   /><br />$trans 0-5</td>
 226     <td><img src="$images[1]" alt="Green" /><br />$trans 6-11</td>
 227     <td><img src="$images[2]" alt="Blue"  /><br />$trans 12-17</td>
 228     <td><img src="$images[3]" alt="Red"   /><br />$trans 18-24</td>
 229   </tr>
 230 </table>
 231
 232 EOF
 233 }
 234
 235 =item B<close_file> ()
 236
 237 Closes the previously opened file. Before it does that though it writed the
 238 HTML-footer which contains some information about onis and closes all HTML-tags
 239 opened by B<open_file>.
 240
 241 =cut
 242
 243 sub close_file
 244 {
 245         my $runtime = time () - $time_start;
 246         my $now = scalar (localtime ());
 247         my ($total_lines, $lines_this_time) = get_total_lines ();
 248         my $lines_per_sec = 'infinite';
 249
 250         $total_lines ||= 0;
 251         $lines_this_time ||= 0;
 252
 253         my $hp    = translate ("onis' homepage");
 254         my $gen   = translate ('This page was generated <span>on %s</span> <span>with %s</span>');
 255         my $stats = translate ('%u lines processed in %u seconds (%s lines per second, %u lines total)');
 256         my $by    = translate ('onis is written %s <span>by %s</span>');
 257         my $link  = translate ('Get the latest version from %s');
 258
 259         my $lps = translate ('infinite');
 260         if ($runtime)
 261         {
 262                 $lps = sprintf ("%.1f", ($lines_this_time / $runtime));
 263         }
 264
 265         print $fh <<EOF;
 266 </div> <!-- class="msie_hack" -->
 267 <!-- This script is under GPL (GNU public license). You may copy and modify it. -->
 268
 269 <table class="copy">
 270   <tr>
 271 EOF
 272         print  $fh '    <td class="left">';
 273         printf $fh ($gen, $now, "onis $::VERSION (&quot;onis not irc stats&quot;)");
 274         print  $fh "<br />\n      ";
 275         printf $fh ($stats, $lines_this_time, $runtime, $lps, $total_lines);
 276         print  $fh qq#\n    </td>\n    <td class="right">\n      #;
 277         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;');
 278         print  $fh qq#<img id="smalllogo" src="http://images.verplant.org/onis-small.png" /># if ($PublicPage);
 279         print  $fh "<br />\n      ";
 280         printf $fh ($link, sprintf (qq#<a href="http://verplant.org/onis/">%s</a>#, $hp));
 281
 282         print $fh <<EOF;
 283
 284     </td>
 285   </tr>
 286 </table>
 287
 288 </body>
 289 </html>
 290 EOF
 291 }
 292
 293 =back
 294
 295 =cut
 296
 297 sub html_escape
 298 {
 299         my @retval = ();
 300
 301         foreach (@_)
 302         {
 303                 my $esc = escape_uris ($_);
 304                 push (@retval, $esc);
 305         }
 306
 307         if (wantarray ())
 308         {
 309                 return @retval;
 310         }
 311         else
 312         {
 313                 return join ("\n", @retval);
 314         }
 315 }
 316
 317 sub escape_uris
 318 {
 319         my $text = shift;
 320         my $retval = '';
 321
 322         return ('') if (!defined ($text));
 323
 324         #if ($text =~ m#(?:(?:ftp|https?)://|www\.)[\w\.-]+\.[A-Za-z]{2,4}(?::\d+)?(?:/[\w\d\.\%/-~]+)?(?=\W|$)#i)
 325         if ($text =~ m#(?:(?:ftp|https?)://|www\.)[\w\.-]+\.[A-Za-z]{2,4}(?::\d+)?(?:/[\w\d\.\%\/\-\~]*(?:\?[\+\w\&\%\=]+)?)?(?=\W|$)#i)
 326         {
 327                 my $orig_match = $&;
 328                 my $prematch = $`;
 329                 my $postmatch = $';
 330
 331                 my $match = $orig_match;
 332                 if ($match =~ /^www/i) { $match = 'http://' . $match; }
 333                 if ($match !~ m#://.+/#) { $match .= '/'; }
 334
 335                 if ((length ($orig_match) > 50) and ($orig_match =~ m#^http://#))
 336                 {
 337                         $orig_match =~ s#^http://##;
 338                 }
 339                 if (length ($orig_match) > 50)
 340                 {
 341                         my $len = length ($orig_match) - 47;
 342                         substr ($orig_match, 47, $len, '...');
 343                 }
 344
 345                 $retval = escape_normal ($prematch);
 346                 $retval .= qq(<a href="$match">$orig_match</a>);
 347                 $retval .= escape_uris ($postmatch);
 348         }
 349         else
 350         {
 351                 $retval = escape_normal ($text);
 352         }
 353
 354         return ($retval);
 355 }
 356
 357 sub escape_normal
 358 {
 359         my $text = shift;
 360
 361         return ('') if (!defined ($text));
 362
 363         $text =~ s/\&/\&amp;/g;
 364         $text =~ s/"/\&quot;/g;
 365         $text =~ s/</\&lt;/g;
 366         $text =~ s/>/\&gt;/g;
 367
 368         # german umlauts
 369         $text =~ s/ä/\&auml;/g;
 370         $text =~ s/ö/\&ouml;/g;
 371         $text =~ s/ü/\&uuml;/g;
 372         $text =~ s/Ä/\&Auml;/g;
 373         $text =~ s/Ü/\&Ouml;/g;
 374         $text =~ s/Ö/\&Uuml;/g;
 375         $text =~ s/ß/\&szlig;/g;
 376
 377         if ($WantColor)
 378         {
 379                 $text = find_colors ($text);
 380         }
 381         else
 382         {
 383                 $text =~ s/[\cB\c_\cV\cO]|\cC(?:\d+(?:,\d+)?)?//g;
 384         }
 385
 386         return ($text);
 387 }
 388
 389 sub find_colors
 390 {
 391         my $string = shift;
 392         my $open_spans = 0;
 393
 394         my $code_ref;
 395
 396         my %flags =
 397         (
 398                 span_open       =>      0,
 399                 fg_color        =>      -1,
 400                 bg_color        =>      -1,
 401                 bold            =>      0,
 402                 underline       =>      0,
 403                 'reverse'       =>      0
 404         );
 405
 406         while ($string =~ m/([\cB\c_\cV\cO])|(\cC)(?:(\d+)(?:,(\d+))?)?/g)
 407         {
 408                 my $controlchar = $1 ? $1 : $2;
 409                 my $fg = defined ($3) ? $3 : -1;
 410                 my $bg = defined ($4) ? $4 : -1;
 411
 412                 my $prematch  = $`;
 413                 my $postmatch = $';
 414
 415                 my $newspan = "";
 416
 417                 # Close open spans first
 418                 if ($flags{'span_open'})
 419                 {
 420                         $newspan .= "</span>";
 421                         $flags{'span_open'} = 0;
 422                 }
 423
 424                 # To catch `\cC' without anything following..
 425                 if (($controlchar eq "\cC") and ($fg == -1) and ($bg == -1))
 426                 {
 427                         $flags{'fg_color'} = -1;
 428                         $flags{'bg_color'} = -1;
 429                 }
 430                 elsif ($controlchar eq "\cC")
 431                 {
 432                         if ($fg != -1)
 433                         {
 434                                 $flags{'fg_color'} = $fg % scalar (@mirc_colors);
 435                         }
 436                         if ($bg != -1)
 437                         {
 438                                 $flags{'bg_color'} = $bg % scalar (@mirc_colors);
 439                         }
 440                 }
 441                 elsif ($controlchar eq "\cB")
 442                 {
 443                         $flags{'bold'} = 1 - $flags{'bold'};
 444                 }
 445                 elsif ($controlchar eq "\c_")
 446                 {
 447                         $flags{'underline'} = 1 - $flags{'underline'};
 448                 }
 449                 elsif ($controlchar eq "\cV")
 450                 {
 451                         $flags{'reverse'} = 1 - $flags{'reverse'};
 452                 }
 453                 # reset
 454                 elsif ($controlchar eq "\cO")
 455                 {
 456                         $flags{'fg_color'} = -1;
 457                         $flags{'bg_color'} = -1;
 458                         $flags{'bold'} = 0;
 459                         $flags{'underline'} = 0;
 460                         $flags{'reverse'} = 0;
 461                 }
 462
 463                 # build the new span-tag
 464                 if (($flags{'fg_color'} != -1) || ($flags{'bg_color'} != -1)
 465                         || $flags{'bold'} || $flags{'underline'})
 466                 {
 467                         my $fg = $flags{'fg_color'};
 468                         my $bg = $flags{'bg_color'};
 469                         my @style = ();
 470
 471                         if ($flags{'reverse'} and ($bg != -1))
 472                         {
 473                                 $fg = $flags{'bg_color'};
 474                                 $bg = $flags{'fg_color'};
 475                         }
 476
 477                         if ($fg != -1)
 478                         {
 479                                 push (@style, 'color: ' . $mirc_colors[$fg] . ';');
 480                         }
 481                         if ($bg != -1)
 482                         {
 483                                 push (@style, 'background-color: ' . $mirc_colors[$bg] . ';');
 484                         }
 485                         if ($flags{'bold'})
 486                         {
 487                                 push (@style, 'font-weight: bold;');
 488                         }
 489                         if ($flags{'underline'})
 490                         {
 491                                 push (@style, 'text-decoration: underline;');
 492                         }
 493
 494                         $newspan .= '<span style="' . join (' ', @style) . '">';
 495                         $flags{'span_open'} = 1;
 496                 }
 497
 498                 $string = $prematch . $newspan . $postmatch;
 499         }
 500
 501         if ($flags{'span_open'})
 502         {
 503                 $string .= "</span>";
 504                 $flags{'span_open'} = 0;
 505         }
 506
 507         return ($string);
 508 }
 509
 510 =head1 AUTHOR
 511
 512 Florian octo Forster E<lt>octo at verplant.orgE<gt>
 513
 514 =cut