1package Onis::Html;
2
3use strict;
4use warnings;
5use Fcntl qw/:flock/;
6use Exporter;
7use Onis::Config qw/get_config/;
8use Onis::Language qw/translate/;
9use Onis::Data::Core qw#get_channel get_total_lines#;
10
11=head1 NAME
12
13Onis::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
20our $fh;
21our $time_start = time ();
22
23=head1 CONFIGURATION OPTIONS
24
25=over 4
26
27=item B<color_codes>: I<false>;
28
29Wether or not to print the color codes (introduced by mIRC, used by idiots and
30ignored by the rest) in the generated HTML-file. Of course this defaults to not
31print the codes..
32
33=cut
34
35our $WantColor = 0;
36if (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
49Wether or not this is a public page. Public pages may be linked on the onis
50homepage at some point in the fututre..
51
52=cut
53
54our $PublicPage = 1;
55if (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
67Sets the stylesheet to use. This is included in the HTML-file as-is, so you
68have to take care of absolute/relative paths yourself..
69
70=cut
71
72our $Stylesheet = 'style.css';
73if (get_config ('stylesheet'))
74{
75	$Stylesheet = get_config ('stylesheet');
76}
77
78=item B<encoding>: I<iso-8859-1>;
79
80Sets the encoding to include in the HTML-file. If you don't know what this is,
81don't change it..
82
83=cut
84
85our $Encoding = 'iso-8859-1';
86if (get_config ('encoding'))
87{
88	$Encoding = get_config ('encoding');
89}
90
91=item B<user>: I<onis>;
92
93Sets the user that created the page. Defaults to the environment variable
94B<USER> or "onis", if it is not set.
95
96=cut
97
98our $User = 'onis';
99if (get_config ('user'))
100{
101	$User = get_config ('user');
102}
103elsif (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
114our @mirc_colors = qw/white black navy green red maroon purple orange
115			yellow lime teal aqua blue fuchsia gray silver/;
116
117my $VERSION = '$Id: Html.pm 74 2005-04-16 08:07:44Z octo $';
118print STDERR $/, __FILE__, ": $VERSION" if ($::DEBUG);
119
120return (1);
121
122=head1 EXPORTED FUNCTIONS
123
124=over 4
125
126=item B<get_filehandle> ()
127
128Returns the filehandle of the output file or undef, if B<open_file> has not
129been called yet.
130
131=cut
132
133sub get_filehandle
134{
135	return ($fh);
136}
137
138=item B<open_file> (I<$filename>)
139
140Opens the file I<$filename> if no file is open at this point. The file is
141exclusively locked and the filehandle stored in the module. The HTML-header is
142printed to the file and the filehandle is returned. You can get another
143reference by calling B<get_filehandle>.
144
145=cut
146
147sub 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
177sub 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">
209EOF
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
232EOF
233}
234
235=item B<close_file> ()
236
237Closes the previously opened file. Before it does that though it writed the
238HTML-footer which contains some information about onis and closes all HTML-tags
239opened by B<open_file>.
240
241=cut
242
243sub 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>
271EOF
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>
290EOF
291}
292
293=back
294
295=cut
296
297sub 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
317sub 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
357sub 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
389sub 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
512Florian octo Forster E<lt>octo at verplant.orgE<gt>
513
514=cut
515