#!/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);
use Apache2::compat;
use HTTP::Body;
use URI;

my $r = Apache2::RequestUtil->request;
my $c = $r->connection;
my $s = $r->server;

# Initialize global variables
my %args = &get_args($r, $c, $s);
   $args{version} = '0.1';

# Apache2 doesn't use the directory in which this file is located as
# its Current Working Directory.
# Extract directory from the Filename and change directory to it.
(my $cwd = $args{Filename}) =~ s/^(.*\/).*?$/$1/;
Cwd::chdir $cwd;

   
# 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: HTTP::Body->upload hashref
#              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   = @_;

	# Headers
	foreach(keys %{$upload->{headers}}) {
		$args{$param.'_Info_'.$_} = $upload->{headers}->{$_};
	}

	# Uploaded file properties
	$args{$param.'_Size'}     = $upload->{size};
	$args{$param.'_Tempname'} = $upload->{tempname};
	$args{$param.'_Filename'} = $upload->{filename};

	# Save file content
	open(F, $upload->{tempname}) || die "Cannot open file ($!)";
	while(<F>) {
		$args{$param} .= $_;
	}
	close F;

	# 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
#     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) = @_;
	my %args;

	my $content = $r->content;

	# fill hash with URI parameters

	# normal parameters
	my $u = URI->new();
	   $u->query($r->args);
	foreach my $key ($u->query_param) {
		my $i = 0;
		foreach my $value ($u->query_param($key)) {
			# parameters can have multiple values,
			# number the ones afther the 1st

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

			$args{$key} = $value;

			$i++;
		}
	}

	# handle POST requests
	if($r->method eq 'POST') {
		if(exists $r->headers_in->{'Content-Type'} &&
		   $r->headers_in->{'Content-Type'} eq 'application/x-www-form-urlencoded'
		) {
			my $u = URI->new();
			   $u->query($content);
			foreach my $key ($u->query_param) {
				my $i = 0;
				foreach my $value ($u->query_param($key)) {
					# parameters can have multiple values,
					# number the ones afther the 1st

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

					$args{$key} = $value;

					$i++;
				}
			}
		}
		elsif(exists $r->headers_in->{'Content-Type'} &&
		      $r->headers_in->{'Content-Type'} =~ /^multipart\/form-data/ &&
		      exists $r->headers_in->{'Content-Length'} &&
		      $r->headers_in->{'Content-Length'} =~ /^\d+$/
		) {
			my $body = HTTP::Body->new(
				$r->headers_in->{'Content-Type'},
				$r->headers_in->{'Content-Length'}
			);
			$body->cleanup(1);
			$body->add($content);

			foreach my $key (keys %{$body->param}) {
				if (ref($body->param->{$key}) eq 'ARRAY') {
					my $i = 0;
					foreach my $value (@{$body->param->{$key}}) {
						# parameters can have multiple values,
						# number the ones afther the 1st

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

						$args{$key} = $value;

						$i++;
					}
				}
				else {
					my $value = $body->param->{$key};

					$args{$key} = $value;
				}
			}

			foreach my $key (keys %{$body->upload}) {
				if (ref($body->upload->{$key}) eq 'ARRAY') {
					my $i = 0;
					foreach my $upload (@{$body->upload->{$key}}) {
						# parameters can have multiple values,
						# number the ones afther the 1st

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

						%args = %{upload_properties($upload, $key, %args)};

						$i++;
					}
				}
				else {
					my $upload = $body->upload->{$key};

					%args = %{upload_properties($upload, $key, %args)};
				}
			}
		}
	}

	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{'Location'}       = $r->location;
	$args{'PathInfo'}       = $r->path_info		if($r->path_info);
	$args{'Args'}           = $r->args;
	$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'}       = $r->useragent_ip;
	if(!$c->remote_host()) {
		$args{'RemoteHostname'} = $r->get_remote_host;
	}
	else {
		$args{'RemoteHostname'} = $c->remote_host;
	}

	$args{'UserAgentIP'}    = $r->useragent_ip;
	$args{'ClientIP'}       = $c->client_ip;

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

	my $uri  = $args{'URI'};
	   $uri .= '?'.$args{'Args'} if($args{'Args'});

	$args{'URL'} = $r->construct_url($uri);

	$args{'Content'} = $content if($content);

	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";
}