#!/usr/bin/perl -w
#
# file    : index.pl
# author  : Bas Couwenberg <sebastic@xs4all.nl>
# license : GPL
#

use strict qw(subs vars);
use Cwd;
use File::Basename;
use Date::Calc qw(:all);

my $apache2 = 0; # assume apache 1.3 by default

# detect apache version of ServerSignature in environment
if($ENV{SERVER_SOFTWARE} =~ /^Apache\/2/i) {
        $apache2 = 1;
}
elsif($ENV{SERVER_SOFTWARE} =~ /^Apache\/1/i) {
	$apache2 = 0;
}

# Apache Request objects
my ($r, $c, $s);
if($apache2 != 1) {
	# Running on Apache 1.3 with mod_perl probably
        
	require Apache::Request;
	import  Apache::Request;
	
	$r = Apache->request;
}
else {
	# Running on Apache 2.x with mod_perl2 probabl
	
	require Apache2::Request;
	require Apache2::Upload;
	require Apache2::compat;
	
	import Apache2::Request;
	import Apache2::Upload;
	import Apache2::compat;
	
	$r = Apache2::RequestUtil->request;
}
$c = $r->connection;
$s = $r->server;

# Initialize global variables
my %args = &get_args($r, $c, $s, $apache2);
   $args{version} = '0.1';
   
# send http header and page content
$r->header_out('Pragma'        => 'no-cache');
$r->header_out('Cache-control' => 'no-cache');
$r->header_out('Connection'    => 'close');

$r->header_out('X-Fortune'     => "This webpage has Super Cow Powers");

$r->content_type('text/html');
$r->send_http_header;
	
# If the UserAgent only requested the HTTP header (using HEAD perhaps),
# we should send it and then exit, skipping the rest of the HTML document.
return 'OK' if $r->header_only;

# print the site HTML
htmlheader( title                => 'HTML to RML converter for Marcelloz DPCH stats',
	    doctype              => 'HTML',
	    doctype_dtd          => 'HTML 4.01 Transitional',
	    doctype_dtd_url      => 'http://www.w3.org/TR/html4/loose.dtd'
	  );

$args{cols} = 100;
$args{rows} = 12;

if($args{html} ne '') {
	$args{rml} = html2rml($args{html});
}

print "<form action='' method='POST'>\n";

print "<b>Convert HTML to RML</b>\n";
print "<br><br>\n";

print "<b>HTML:</b><br>\n";
print "<textarea name='html' cols='$args{cols}' rows='$args{rows}'>$args{html}</textarea><br>\n";
print "<br>\n";
	
print "<b>RML:</b><br>\n";
print "<textarea name='rml' cols='$args{cols}' rows='$args{rows}'>$args{rml}</textarea><br>\n";
print "<br>\n";

print "<input type='submit' name='submit' value='Convert'>\n";
	
print "</form>\n";

print "<br><br>\n";
print "<a href='index.pl.txt'>Source Code</a>";
	
htmlfooter();


################################[ Subroutines ]################################

sub html2rml {
	my $data = shift;
		
	# strip the [norml] RML tags
	if($data =~ s/\[\/?norml\]\r?\n?//ig) {}

	# strip the <font> HTML tags
	while($data =~ /(<font(.*?)>(.*?)<\/font>)/ig) {
		my $tag  = $1;
		my $args = $2;
		my $text = $3;

		if($args =~ m/color='#(.*?)'/) {
			my $hex = $1;
			
			if($hex =~ /ff0000/) {
				$text = "[red]$text\[/red]";
			}
			elsif($hex =~ /00ff00/) {
				$text = "[green]$text\[/green]";
			}
			elsif($hex =~ /0000ff/) {
				$text = "[blue]$text\[/blue]";
			}
		}
	
		$data =~ s/\Q$tag\E/$text/ig;
	}
	if($data =~ s/<\/font>//g) {}


	# convert <table> HTML tags
	while($data =~ /<table(.*?)>/ig) {
		my $s1 = $1;
		my $s2 = $1;
		if($s2 =~ s/'//g) {}
		if($s2 =~ s/"//g) {}

		$data =~ s/<table\Q$s1\E>/[table$s2]\n/ig;
	}
	if($data =~ s!</table>!\[/table\]\n!ig) {}

	# convert the <tr> HTML tags
	while($data =~ /<tr(.*?)>/i) {
		my $s1 = $1;
		my $s2 = $1;
		if($s2 =~ s/^ $//g) {}
		if($s2 =~ s/'//g) {}
		if($s2 =~ s/"//g) {}
	
		$data =~ s/<tr\Q$s1\E>/[tr$s2]\n/ig;
	}
	if($data =~ s!</tr>![/tr]\n!ig) {}

	# convert the <td> HTML tags
	while($data =~ /<td(.*?)>/i) {
		my $s1 = $1;
		my $s2 = $1;
		if($s2 =~ s/^ $//g) {}
		if($s2 =~ s/'//g) {}
		if($s2 =~ s/"//g) {}

		$data =~ s/<td\Q$s1\E>/[td$s2]\n/ig;
	}
	if($data =~ s!</td>!\n[/td]\n!ig) {}

	# convert the <a href> tags
	while($data =~ /(<a href='(.*?)'( (target|class)=.*?)?>(.*?)<\/a>)/i) {
		my $tag   = $1;
		my $url   = $2;
		my $name  = $5;

		if($url =~ s/\[/\%5B/g){}
		if($url =~ s/\]/\%5D/g){}
		
		$data =~ s/\Q$tag\E/[url=$url]$name\[\/url]/ig;
	}

	# convert the <img> tags
	while($data =~ /(<img src='(.*?)'( .*?)?>)/i) {
		my $tag = $1;
		my $url = $2;

		$data =~ s/\Q$tag\E/[img]$url\[\/img]/ig;
	}
	
	# convert the <b> HTML tags
	if($data =~ s!<(\/?)b>![$1b]!ig) {}

	# convert the <br> HTML tags
	if($data =~ s!<br>![br]!ig) {}

	return $data;
}

##############
#
#     Routine: get_date()
#  Parameters: optionally a hash with the keys date and/or time set to something
#     Returns: the date in yyyy-mm-dd format, if only date is set
#              the time in hh:mm:ss format, if only time is set
#              the full date in yyyy-mm-dd hh:mm:ss format, if neither date and 
#              time are set
#              both the date and the time, if they're both set
# Description: Get the contents and other info of uploaded data
#   

sub get_date {
	my %option = @_;

	my ($year,$month,$day,$hour,$min,$sec) = Date::Calc::Today_and_Now();
	
	$month = '0'.$month if(length($month) == 1);
	$day   = '0'.$day   if(length($day)   == 1);
	$hour  = '0'.$hour  if(length($hour)  == 1);
	$min   = '0'.$min   if(length($min)   == 1);
	$sec   = '0'.$sec   if(length($sec)   == 1);
	
	my $date = "$year-$month-$day";
	my $time = "$hour:$min:$sec";

	if(!$option{date} && !$option{time}) {
		return "$date $time";
	}
	elsif($option{time} && !$option{date}) {
		return $time;
	}
	elsif($option{date} && !$option{time}) {
		return $date;
	}
	else {
		return ($date, $time);
	}
}

##############
#
#     Routine: upload_properties()
#  Parameters: Apache::Upload object
#              Parameter name
#              %args
#     Returns: updated hash with HTTP headers, URL variables, and other global variables
# Description: Get the contents and other info of uploaded data
#   

sub upload_properties {
        my $upload = shift;  # upload object
	my $param  = shift;  # parameter name
	my %args   = @_;
	
	# Uploaded file properties
	$args{$param.'_Size'}     = $upload->size;
	$args{$param.'_Type'}     = $upload->type;
	$args{$param.'_Tempname'} = $upload->tempname;
	$args{$param.'_Filename'} = $upload->filename;

	# Save file content
	my $fh = $upload->fh;
	while (<$fh>) {
		$args{$param} .= $_;
	}

	# strip the filename from the start of the data
	if($args{$param} =~ s/^\Q$args{$param.'_Filename'}\E//) {}

	# handle files uploaded with Internet Explorer
	# instead of just the filename, IE sends the whole path
	# example:
	# X:\Porn\Pics\NakedLady.jpg
	
	if($args{$param.'_Filename'} =~ /^\w:.*\\(.*?)$/) {
		$args{$param.'_Filename'} = $1;
	}
	
	return \%args;
}
						
	
##############
#
#     Routine: get_args()
#  Parameters: Apache::Request object
#              Apache::Connection object
#              Apache::Server object
#              Apache2 flag
#     Returns: hash with HTTP headers, URL variables, and other global variables
# Description: get the information from the HTTP request and Apache API, 
#              and set global variables
#   
   
sub get_args {
	my ($r, $c, $s, $apache2) = @_;
	my %args;

	# fill hash with URI parameters

	my $apr;
	if($apache2 != 1) {
		$apr = Apache::Request->new($r);
	}
	else {
		$apr = Apache2::Request->new($r);
	}

	# normal parameters
	foreach my $param ($apr->param) {
		my $i = 0;
		foreach my $value ($apr->param($param)) {
			# parameters can have multiple values,
			# number the ones afther the 1st
			
			$param .= $i if($i > 0);
			
			$args{$param} = $value;
			
			$i++;
		}
	}

	# handle POST requests
	if($r->method eq 'POST') {
		# uploaded files
		if($apache2 != 1) {
			for my $upload ($apr->upload) {
				my $param = $upload->name;
				
				foreach(keys %{$upload->info}) {
					$args{$param.'_Info_'.$_} = $upload->info($_);
				}
				
				%args = %{upload_properties($upload, $param, %args)};
			}
		}
		else {
			my $upload_table_ref = $apr->upload; # APR::Table ref of uploads
			
			foreach my $name (keys %$upload_table_ref) {
				my $i = 0;
				foreach my $upload ($apr->upload($name)) {
					my $param = $upload->name;
					
					# parameters can have multiple values,
					# number the ones afther the 1st

					$param .= $i if($i > 0);

					
					foreach(keys %{$upload->info}) {
						$args{$param.'_Info_'.$_} = $upload->info->{$_};
					}
					
					%args = %{upload_properties($upload, $param, %args)};
					
					$i++;
				}
			}
		}
	}
	
	my ($date, $time) = get_date(date => 1, time => 1);

	$args{'Date'}		= $date;
	$args{'Time'}		= $time;
	$args{'User'}           = $c->user		if defined($c->user);
	$args{'Protocol'}   	= $r->protocol;
	
	$args{'Bytes'}		= $r->bytes_sent	if($r->bytes_sent);
	$args{'Method'}		= $r->method;
	$args{'MethodNumber'}   = $r->method_number;
	$args{'Request'}        = $r->the_request;
	$args{'RequestTime'}    = $r->request_time;
	$args{'URI'}            = $r->uri;
	$args{'Filename'}       = $r->filename;
	$args{'PathInfo'}       = $r->path_info		if($r->path_info);
	$args{'DocumentRoot'}   = $r->document_root;
	
	$args{'UserAgent'}      = $r->header_in('User-Agent');	# for compatibility with old scripts	

	foreach(keys %{$r->headers_in()}) {
		$args{$_} = $r->headers_in->{$_};
	}
	
	$args{'Hostname'}   	= $r->hostname;
	$args{'AuthName'}	= $r->auth_name		if($r->auth_name);
	$args{'AuthType'}	= $c->auth_type		if($c->auth_type);
	$args{'RemoteIP'}	= $c->remote_ip;
	if($c->remote_host() eq '') {
		$args{'RemoteHostname'} = $r->get_remote_host;
	}
	else {
		$args{'RemoteHostname'} = $c->remote_host;
	}

	$args{'ServerName'}     = $s->server_hostname;
	$args{'ServerAdmin'}    = $s->server_admin;
	$args{'ServerPort'}     = $s->port;
	$args{'ServerSoftware'} = $ENV{SERVER_SOFTWARE};	

	return %args;
}


##############
#
#     Routine: html_footer()
#  Parameters: hash of tags to generate
#     Returns: nothing
# Description: print the tags of the header of the html page
#   

sub htmlheader {
	my %args = @_;
	
	if($args{doctype}) {
		print "<!DOCTYPE $args{doctype} PUBLIC \"-//W3C//DTD ";
		if($args{doctype_dtd}) {
			print "$args{doctype_dtd} ";
		}
		else {
			print "$args{doctype} ";
		}
		
		if($args{doctype_language}) {
			print "//$args{doctype_language}\"";
		}
		else {
			print "//EN\"";
		}

		if($args{doctype_dtd_url}) {
			print " \"$args{doctype_dtd_url}\"";
		}
		print ">\n";
	}
	
	print "<html>\n";
	print "<head>\n";
	print "\t<title>$args{title}</title>\n" if($args{title});
	if($args{meta1_name}) {
		my $i = 1;
		while($args{'meta' . $i . '_name'}) {
			print "\t<meta";
			
			my $meta_name = $args{'meta' . $i . '_name'} if($args{'meta' . $i . '_name'});
			print " name=\"$meta_name\"" if($args{'meta' . $i . '_name'});
			
			my $meta_equiv = $args{'meta' . $i . '_equiv'} if($args{'meta' . $i . '_equiv'});
			print " http-equiv=\"$meta_equiv\"" if($args{'meta' . $i . '_httpequiv'});
			
			my $content  = $args{'meta' . $i . '_content'} if($args{'meta' . $i . '_content'});
			print " content=\"$content\"" if($args{'meta' . $i . '_content'});

			print ">\n";
			
			$i++;
		}
	}
	if($args{link1}) {
		my $i = 1;
		while($args{'link' . $i}) {
			print "\t<link";
			
			my $linktype = $args{'link' . $i . '_type'} if($args{'link' . $i . '_type'});
			print " type=\"$linktype\"" if($args{'link' . $i . '_type'});
			
			my $linkrel  = $args{'link' . $i . '_rel'} if($args{'link' . $i . '_rel'});
			print " rel=\"$linkrel\"" if($args{'link' . $i . '_rel'});
			
			print " href=\"$args{'link' . $i}\">\n";

			$i++;
		}
	}
	if($args{script1}) {
		my $i = 1;
		while($args{'script' . $i}) {
			print "\t<script";
			
			my $scripttype = $args{'script' . $i . '_type'} if($args{'script' . $i . '_type'});
			print " type=\"$scripttype\"" if($args{'script' . $i . '_type'});
			
			my $scriptlanguage  = $args{'script' . $i . '_language'} if($args{'script' . $i . '_language'});
			print " language=\"$scriptlanguage\"" if($args{'script' . $i . '_language'});
			
			print " src=\"$args{'script' . $i}\"></script>\n";
			
			$i++;
		}
	}
	print "\t<style>$args{style}</style>\n" if($args{style});
	
	print "</head>\n\n";
	
	print "<body";
	print " onUnload=\"$args{body_onunload}\"" if($args{body_onunload});
	print " onLoad=\"$args{body_onload}\"" if($args{body_onload});
	print ">\n\n";
}


##############
#
#     Routine: htmlfooter()
#  Parameters: none
#     Returns: nothing
# Description: print the closing tags for the html page
#

sub htmlfooter {
	print "\n</body>\n";
	print "</html>\n";
}