7 use Onis::Config qw/get_config/;
8 use Onis::Language qw/translate/;
9 use Onis::Data::Core qw#get_channel get_total_lines#;
13 Onis::Html - Low level page generation stuff..
17 @Onis::Html::EXPORT_OK = qw/open_file close_file get_filehandle html_escape/;
18 @Onis::Html::ISA = ('Exporter');
21 our $time_start = time ();
23 =head1 CONFIGURATION OPTIONS
27 =item B<color_codes>: I<false>;
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
36 if (get_config ('color_codes'))
38 my $temp = get_config ('color_codes');
39 if (($temp eq 'print') or ($temp eq 'true')
47 =item B<public_page>: I<true>;
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..
55 if (get_config ('public_page'))
57 my $temp = get_config ('public_page');
59 if ($temp =~ m/false|off|no/i)
65 =item B<stylesheet>: I<style.css>;
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..
72 our $Stylesheet = 'style.css';
73 if (get_config ('stylesheet'))
75 $Stylesheet = get_config ('stylesheet');
78 =item B<encoding>: I<iso-8859-1>;
80 Sets the encoding to include in the HTML-file. If you don't know what this is,
85 our $Encoding = 'iso-8859-1';
86 if (get_config ('encoding'))
88 $Encoding = get_config ('encoding');
91 =item B<user>: I<onis>;
93 Sets the user that created the page. Defaults to the environment variable
94 B<USER> or "onis", if it is not set.
99 if (get_config ('user'))
101 $User = get_config ('user');
103 elsif (defined ($ENV{'USER'}))
105 $User = $ENV{'USER'};
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/;
117 my $VERSION = '$Id$';
118 print STDERR $/, __FILE__, ": $VERSION" if ($::DEBUG);
122 =head1 EXPORTED FUNCTIONS
126 =item B<get_filehandle> ()
128 Returns the filehandle of the output file or undef, if B<open_file> has not
138 =item B<open_file> (I<$filename>)
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>.
153 print STDERR $/, __FILE__, ": Not opening file ``$file'': Another file is already open!";
157 unless (open ($fh, "> $file"))
159 print STDERR $/, __FILE__, ": Unable to open file ``$file'': $!";
163 unless (flock ($fh, LOCK_EX))
165 print STDERR $/, __FILE__, ": Unable to exclusive lock file ``$file'': $!";
175 # Generates the HTML header including the CSS information.
176 # Doesn't take any arguments
179 my $generated_time = scalar (localtime ($time_start));
182 my $channel = get_channel ();
184 my @images = get_config ('horizontal_images');
187 @images = qw#images/hor0n.png images/hor1n.png images/hor2n.png images/hor3n.png#;
190 $trans = translate ('%s statistics created by %s');
191 my $title = sprintf ($trans, $channel, $User);
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">
199 <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
201 <title>$title</title>
202 <meta http-equiv="Cache-Control" content="public, must-revalidiate" />
203 <link rel="stylesheet" type="text/css" href="$Stylesheet" />
208 <div class="msie_hack">
211 $trans = translate ('%s stats by %s');
212 $title = sprintf ($trans, $channel, $User);
214 $trans = translate ('Statistics generated on %s');
215 my $time_msg = sprintf ($trans, $generated_time);
217 $trans = translate ('Hours');
223 <table class="legend">
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>
235 =item B<close_file> ()
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>.
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';
251 $lines_this_time ||= 0;
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');
259 my $lps = translate ('infinite');
262 $lps = sprintf ("%.1f", ($lines_this_time / $runtime));
266 </div> <!-- class="msie_hack" -->
267 <!-- This script is under GPL (GNU public license). You may copy and modify it. -->
272 print $fh ' <td class="left">';
273 printf $fh ($gen, $now, "onis $::VERSION ("onis not irc stats")");
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><octo@<span class="spam">nospam.</span>verplant.org>');
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));
303 my $esc = escape_uris ($_);
304 push (@retval, $esc);
313 return join ("\n", @retval);
322 return ('') if (!defined ($text));
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)
331 my $match = $orig_match;
332 if ($match =~ /^www/i) { $match = 'http://' . $match; }
333 if ($match !~ m#://.+/#) { $match .= '/'; }
335 if ((length ($orig_match) > 50) and ($orig_match =~ m#^http://#))
337 $orig_match =~ s#^http://##;
339 if (length ($orig_match) > 50)
341 my $len = length ($orig_match) - 47;
342 substr ($orig_match, 47, $len, '...');
345 $retval = escape_normal ($prematch);
346 $retval .= qq(<a href="$match">$orig_match</a>);
347 $retval .= escape_uris ($postmatch);
351 $retval = escape_normal ($text);
361 return ('') if (!defined ($text));
363 $text =~ s/\&/\&/g;
364 $text =~ s/"/\"/g;
365 $text =~ s/</\</g;
366 $text =~ s/>/\>/g;
369 $text =~ s/ä/\ä/g;
370 $text =~ s/ö/\ö/g;
371 $text =~ s/ü/\ü/g;
372 $text =~ s/Ä/\Ä/g;
373 $text =~ s/Ü/\Ö/g;
374 $text =~ s/Ö/\Ü/g;
375 $text =~ s/ß/\ß/g;
379 $text = find_colors ($text);
383 $text =~ s/[\cB\c_\cV\cO]|\cC(?:\d+(?:,\d+)?)?//g;
406 while ($string =~ m/([\cB\c_\cV\cO])|(\cC)(?:(\d+)(?:,(\d+))?)?/g)
408 my $controlchar = $1 ? $1 : $2;
409 my $fg = defined ($3) ? $3 : -1;
410 my $bg = defined ($4) ? $4 : -1;
417 # Close open spans first
418 if ($flags{'span_open'})
420 $newspan .= "</span>";
421 $flags{'span_open'} = 0;
424 # To catch `\cC' without anything following..
425 if (($controlchar eq "\cC") and ($fg == -1) and ($bg == -1))
427 $flags{'fg_color'} = -1;
428 $flags{'bg_color'} = -1;
430 elsif ($controlchar eq "\cC")
434 $flags{'fg_color'} = $fg % scalar (@mirc_colors);
438 $flags{'bg_color'} = $bg % scalar (@mirc_colors);
441 elsif ($controlchar eq "\cB")
443 $flags{'bold'} = 1 - $flags{'bold'};
445 elsif ($controlchar eq "\c_")
447 $flags{'underline'} = 1 - $flags{'underline'};
449 elsif ($controlchar eq "\cV")
451 $flags{'reverse'} = 1 - $flags{'reverse'};
454 elsif ($controlchar eq "\cO")
456 $flags{'fg_color'} = -1;
457 $flags{'bg_color'} = -1;
459 $flags{'underline'} = 0;
460 $flags{'reverse'} = 0;
463 # build the new span-tag
464 if (($flags{'fg_color'} != -1) || ($flags{'bg_color'} != -1)
465 || $flags{'bold'} || $flags{'underline'})
467 my $fg = $flags{'fg_color'};
468 my $bg = $flags{'bg_color'};
471 if ($flags{'reverse'} and ($bg != -1))
473 $fg = $flags{'bg_color'};
474 $bg = $flags{'fg_color'};
479 push (@style, 'color: ' . $mirc_colors[$fg] . ';');
483 push (@style, 'background-color: ' . $mirc_colors[$bg] . ';');
487 push (@style, 'font-weight: bold;');
489 if ($flags{'underline'})
491 push (@style, 'text-decoration: underline;');
494 $newspan .= '<span style="' . join (' ', @style) . '">';
495 $flags{'span_open'} = 1;
498 $string = $prematch . $newspan . $postmatch;
501 if ($flags{'span_open'})
503 $string .= "</span>";
504 $flags{'span_open'} = 0;
512 Florian octo Forster E<lt>octo at verplant.orgE<gt>