#!/usr/local/bin/perl56 -wT
#Can't execute this one, it is the library of files for parsing the query string
#noexec
# File: CGILib.pm
# hash get_cookie()
#    Return a hash array of all the name value pairs in the HTTP_COOKIE variable
# hash get_query()
#    Return a hash array of all the name value pairs in the QUERY_STRING variable, or from STDIN
# string url_encode(string)
#    Return a string that has special characters translated to %xx
# string url_decode(string)
#    Return a string that translates %xx back to special characters
# string html_encode(string)
#    Return a string that translates & < > to &amp; &lt; &gt;
# void print_head(title, bgcolor, css, header, js)
#    Print the standard HTML codes, setting the title and background color. Use css if provided.
#    Print additional header if provided. Use JavaScript if provided.
# void print_tail
#    Print the standard closing HTML codes
# void print_error
#    Arguments are
#      A hash indexed by field name containing ["error message", 'class="error class"]
#      A list of field names    
# void printHTTP_header(mime_type)
#    Print the Content-type header for the given mime type, text/html is the default
# string time_gmt(seconds)
#    Return a GMT formatted string from the current time pluse seconds
# void display_file(system_path, mime_type, mode)
#    Print a file to standard out with the given content-type. 
#    Use a non-zero mode to indicate text mode instead of the default binary mode.
# void redirect(url)
#    Print the relocation header for the given URL
# string encode_data(list)
#    Return a string that contains all the fields in the list separated by '\t'
# list decode_data(string)
#    Return a list of the fields in string that are separated by '\t'

package CGILib;

use Exporter;
@ISA = "Exporter";
@EXPORT = qw( get_cookie print_head print_tail print_error print_HTTP_header redirect display_file get_query time_gmt print_tail url_encode url_decode html_encode encode_data decode_data);

@table = qw(0 1 2 3 4 5 6 7 8 9 A B C D E F);
@mon2str = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
@wday2str = qw(Sun Mon Tue Wed Thu Fri Sat);

# ------------------ QUERY PARSING ROUTINE HERE ------------
sub get_cookie {
    local($cookie_env)=$ENV{'HTTP_COOKIE'};
    local($param,$value,%cookie);

    if ($cookie_env)
    {
	$cookie_env=~tr/ //d;
	@pairs=split(';',$cookie_env);
	foreach (@pairs)
	{
	    ($param,$value) = split('=');
	    $param = url_decode($param);
	    $value = url_decode($value);
	    if ($cookie{$param}) {
		$cookie{$param} .= "$;$value";
	    } else {
		$cookie{$param} = $value;
	    }
	}
    }

    return %cookie;
}


sub get_query {
    local($query_string);
    local(@lines);
    local($method)=$ENV{'REQUEST_METHOD'};

    # If method is GET fetch the query from
    # the environment.
    if (defined $method) {
	if ($method eq 'GET') {
	    $query_string = $ENV{'QUERY_STRING'};
	    
	    # If the method is POST, fetch the query from standard in
	} elsif ($method eq 'POST') {
	    read(STDIN,$query_string,$ENV{'CONTENT_LENGTH'});
	}
    }

    # No data.  Return an empty array.
    return () unless $query_string;	

    # We now have the query string.
    # Call parse_params() to split it into key/value pairs
    return parse_params($query_string);
}

sub parse_params {
    local($tosplit) = @_;
	local(@pairs) = split('&',$tosplit);
	local($param,$value,%parameters);

	foreach (@pairs) {
#            @parts = split('=');
#	    $param = shift @parts;
#            $value = join(@parts);
	    ($param, $value) = split('=');
	    $param = url_decode($param);
	    $value = url_decode($value);
	    if ($parameters{$param}) {
		$parameters{$param} .= "$;$value";
	    } else {
		$parameters{$param} = $value;
	    }
	}
	return %parameters;
}

sub url_encode {
    my $text = shift;
    $text =~ s/([^a-z0-9_.!~*'() -])/sprintf "%%%02X", ord($1)/egi;
    $text =~ tr/ /+/;
    return $text;
}


sub url_decode {
    my $text = shift;
    $text =~ tr/+/ /;
    $text =~ s/%([0-9a-fA-F]{2})/chr(hex($1))/ge;
    return $text;
}

sub cookie_encode {
    
}

sub cookie_decode {

}

sub html_encode {
    my $line = shift;
    $line =~ s/&/&amp;/g;
    $line =~ s/</&lt;/g;
    $line =~ s/>/&gt;/g;
    return $line;
}

#Print title and heading using paramter
sub print_head {
    local($Title,$Color,$CSS,$header,$javascript) = @_;
    print <<START;
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
"http://www.w3.org/TR/html4/loose.dtd">
<HTML><HEAD>
$header
<meta http-equiv="content-type" content="text/html; charset=utf-8">
<TITLE>$Title</TITLE>
START
;
    if ($CSS) {
	print "<link rel='stylesheet' type='text/css' href='$CSS'>\n";
    }
    if ($javascript) {
	print "<script>$javascript</script>";
    }
    print <<END;
</HEAD>
<BODY $Color>
<H1>$Title</H1>
END
    ;
}

#Print the closing HTML codes
sub print_tail {
    print "</body></html>\n";
}

############################################################################
sub print_error {
    my ($refFields, %error) = @_;
    my @fields = @$refFields;
    my $msg;
    print "<table border='0'><tr><td>\n";
    print "<ul class='error'>\n";
    foreach (@fields) {
	if ($msg = $error{$_}[0]) {
	    print "\t<li>$_ $msg</li>\n";
	}
    }
    print "</ul></td></tr></table><hr />\n";
}

#Print the HTTP header for HTML
sub print_HTTP_header {
    my($mime) = shift;
    $mime = "text/html" unless $mime;
    print "Content-type: $mime\n\n";
}

sub xwday2str {
    my($wday)=@_;
    if ($wday == 0) {return "Sunday"}
    elsif ($wday == 1) {return "Monday"}
    elsif ($wday == 2) {return "Tuesday"}
    elsif ($wday == 3) {return "Wednesday"}
    elsif ($wday == 4) {return "Thursday"}
    elsif ($wday == 5) {return "Friday"}
    elsif ($wday == 6) {return "Saturday"}
    else {return "Error in weekday number"};
}

sub xmon2str {
    my($mon)=@_;
    if ($mon == 0) {return "January"}
    elsif ($mon == 1) {return "February"}
    elsif ($mon == 2) {return "March"}
    elsif ($mon == 3) {return "April"}
    elsif ($mon == 4) {return "May"}
    elsif ($mon == 5) {return "June"}
    elsif ($mon == 6) {return "July"}
    elsif ($mon == 7) {return "August"}
    elsif ($mon == 8) {return "September"}
    elsif ($mon == 9) {return "October"}
    elsif ($mon == 10) {return "November"}
    elsif ($mon == 11) {return "December"}
    else {return "Error in month number"};
}

sub time_gmt {
    my($plus) = @_;
    my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst);
    my($mname,$wname,$time,$gmt);

    $time=time + $plus;
    ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($time);
    $mname=xmon2str($mon);
    $wname=xwday2str($wday);
    $year -= 100 if ($year > 99);
    $gmt=$wname . ", " . dig2($mday) . "-" . $mname . "-" . dig2($year);
    $gmt.= " " . dig2($hour) . ":" . dig2($min) . ":" . dig2($sec) . " GMT";
    return $gmt;
}

sub display_file {
    # Receive the path to the image as a parameter
    my ($full_path,$mime,$mode) = @_;
    
    # Return an error message if it can't be opened
    open FILE, $full_path or return "Couldn't open $full_path";
    
    print "Pragma: no-cache\n";
    print "Content-type: $mime\n\n";
    
    # Prevent the server from mangling bytes that have the value of \n
    binmode STDOUT unless $mode;

    # Read 16,384 bytes at a time from the image and send to the browser
    # Continue until all bytes have been transmitted.
    my $buffer = "";
    while ( read( FILE, $buffer, 16_384 ) ) {
        print $buffer;
    }
    close FILE;

    # Return an empty string if everything went OK
    return "";
}

#Print the HTTP header for HTML
sub redirect {
    my ($URL) = @_;
    print "Location: $URL\n\n";
}


sub dig2 {
    my($str)=@_;
    if ($str < 10)
    {
	$str = "0" . $str;
    }
    return $str;
}

sub encode_data {
    my @fields = map {
	s/\\/\\\\/g;
	s/\t/\\t/g;
	s/\n/\\n/g;
	s/\r/\\r/g;
	$_;
    } @_;

    my $line = join "\t", @fields;
    return $line . "\n";
}

sub decode_data {
    my $line = shift;

    chomp $line;
    my @fields = split /\t/, $line;
    return map {
	s/\\(.)/$1 eq 't' and "\t" or
	        $1 eq 'n' and "\n" or
		$1 eq 'r' and "\r" or
		"$1"/eg;
	$_;
    } @fields;
}

1;