#!/usr/npac/bin/perl
#
# password-form.pl
#    --	A CGI script to add a line containing calendar information 
#	to a file by virtue of a password-protected form.
#
#	This version of password-form.pl stores the password unencrypted
#	and does not use the perl crypt function.  Use this if you have
#	problems using crypt, or don't want to encrypt your stored password.
# ----------------------------------------------------------------------
# Written by Collin Forbes in April, 1996 as "password-form.pl".
# Rewritten and modified by Collin Forbes in August, 1996.
# Further rewritten and updated in March, 1998
#
# Use this script as the POST action of a form with the following fields
#
# <input name=password> (required)  The password that attempts to verify
#	that the user who has submited the form is authorized to add dates
#	to the calendar.
#
# <input name=event> (required) The text of the event.
#
# <input name=file> (sort-of-required) The "nickname" of the configuration
#	file to use.  This file contains configuration information as well
#	as dates or events in the following format:
#		"year<tab>month<tab>day<tab>event<newline>"
#	You can use "any" in any of the fields to make an event	repeat.
#
# <input name=year> (optional)  The year of the event.  Either a numeric
#	value (1970-2049) or a keyword "any", "next", "current", or "previous"
#	(if you want to be retroactive).  If ommitted, defaults to the 
#	current year.
#
# <input name=month> (optional) The month of the event.  Either a numeric
#	value (1-12) or a keyword "any", "next", "current", or "previous"
#	(if you want to be retroactive).  If ommitted, defaults to the
#	current month.
#
# <input name=day> (required) The day of the event.  Either a numeric
#	value (1-31) or "any".  No default, error if this is ommitted.
#
# <input name=event> (required) The actual text of the event
#
# Configuration Section ------------------------------------------

$SCRIPT_PASSWORD = "password";
#
# $SCRIPT_PASSWORD is the password to match against.
#

%CONFIGURATION_FILE = (
        '' => '/home/collinf/public_html/scripts/calendar/config.txt',
        'calendar' => '/home/collinf/public_html/scripts/calendar/config.txt',
        );
#
# You can use the keys of the %configuration_file array to point to
# different "nicknames" to use different configuration files.
# The '' (no text, just two quotes) key will be the default.
#
# This array should be *identical* to the array of the same name in the 
# calendar.pl script.
# 

$PASSWORD_FORM_URL = '/~collinf/scripts/calendar/password-form.cgi';
#
# $password_form_url is the URL of the password-protected form.  This
# variable is used to provide a link back to the form on the success page.
#
# ------------------------------------------------------------------

%FORM = &receive_form_information;

&error('$SCRIPT_PASSWORD not set') unless $SCRIPT_PASSWORD;
&error("nothing in the event input") unless $FORM{'event'};
$CONFIG_FILENAME = $CONFIGURATION_FILE{ $FORM{'nickname'} };

if ( $FORM{'password'} eq $SCRIPT_PASSWORD ) {
    $HTML = &handle_password_form($PASSWORD_FORM_URL,$CONFIG_FILENAME,%FORM);
}
else { $HTML = &password_challenge( $PASSWORD_FORM_URL, %FORM ); }

&print_html( $HTML );
exit;

# Subroutine Section ---------------------------------------------

sub handle_password_form {
#
# adds the date information to the end of the configuration/date file
#
    local( $url, $filename, %f ) = @_;
    local( $html );

    ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdist) = localtime(time);
    $month = $mon + 1;
    $year = 1900 + $year;

    if ( $f{'day'} !~ m/^\d+$/ ) { $f{'day'} = 'any'; }
    #
    # Convert form dates/keywords into real values.  
    #
    # Bounds checking on the numeric values is not performed.  If you want
    # to put garbage into your configuration file, you may do so--it won't
    # hurt the calendar script.
    #
    # Months are either numeric (1-12) or one of the keywords 
    #	"any", "current", "next", or "previous".
    #
    # use $f{'mon'} if it's available, but $f{'month'} has priority.
    $f{'mon'} = $f{'month'} unless $f{'month'};

    if ( $f{'month'} !~ m/^\d+$/ ) {
	if ( $f{'month'} =~ m/any/i )  { $month = 'any'; }
	elsif ( $f{'month'} =~ m/next/i ) { $month++; }		# Increment
        elsif ( $f{'month'} =~ m/prev/i ) { $month--; } 	# Decrement
	# otherwise it's okay to use the current month
    }
    else { $month = $f{'month'}; }
    #
    # Years are either numeric (1970-2049) or one of the keywords
    #	"any", "current", "next", or "previous".
    #
    if ( $f{'year'} !~ m/^\d+$/ ) {
	if ( $f{'year'} =~ m/any/i )  { $year = 'any'; }
	elsif ( $f{'year'} =~ m/next/i ) { $year++;  }	# Increment
	elsif ( $f{'year'} =~ m/prev/i ) { $year--;  }	# Decrement
	# otherwise it's okay to use the current year
    }
    # add 1900 to old-style (2 or 3 digit) years
    elsif ( $year < 200 ) { $year = 1900 + $f{'year'}; }
    else { $year = $f{'year'}; }
    #
    # Days are either numeric (1-31) or the keyword "any"
    #
    if ( $f{'day'} !~ m/^\d+$/ ) { $mday = 'any'; }
    else { $mday = $f{'day'}; }

    open(FILE, ">>$filename") || &error("opening file: $filename");
    print FILE "$year\t$month\t$mday\t$f{'event'}\n";
    close FILE;

    # feel free to be more verbose in the output
    $html  = qq|<HTML>\n| .
	     qq|<HEAD>\n| .
	     qq|<TITLE>Event Saved</TITLE>\n| .
	     qq|</HEAD>\n| .
	     qq|<BODY BGCOLOR="#ffffff" TEXT="#000000">\n| .
	     qq|<FONT SIZE="5">Your event has been written to the file</FONT>| .
	     qq|</BODY>| .
	     qq|</HTML>|;

    $html;			# return value for subroutine
}


sub password_challenge {
#
# generates a form with the password prompt.
# the previous input values are recycled into hidden form elements.
# kind of depends on &convert_entities to be around as well
#
    local( $url, %input ) = @_;
    local( $form, $key );

    delete( $input{'password'} );  # remove an invalid password

    %input = &convert_entities( %input );	# protect the hidden fields
 
    $form = qq|<HTML>\n| .
	    qq|<HEAD>\n<TITLE>Password Challenge</TITLE>\n</HEAD>\n| .
	    qq|<BODY BGCOLOR="#ffffff" TEXT="#000000">\n|;

    $form .= qq|<P>You must enter the correct password to continue.\n|;
    $form .= qq|<FORM ACTION="$url" METHOD=POST>\n|;
    foreach $key ( keys %input ) {
        $form .= qq|<INPUT NAME="$key" TYPE=hidden VALUE="$input{$key}">\n|;
    }
    $form .= qq|<SMALL>Password: |;
    $form .= qq|<INPUT NAME="password" TYPE=password>\n|;
    $form .= qq|<INPUT TYPE=submit VALUE="continue"></SMALL>\n|;
    $form .= qq|</FORM>\n|;

    $form .= qq|</BODY>\n</HTML>\n|;

    $form;			# return value for subroutine
}

sub convert_entities {
#
# Check the values of the given associative array and change
# any special characters into SGML entities.
#
    local( %array ) = @_;
    local( %en ) = (
	'>'=>'gt',       '<'=>'lt',       '"'=>'quot',
	"\xA0","nbsp",  "\xA1","iexcl", "\xA2","cent",  "\xA3","pound",
	"\xA4","curren","\xA5","yen",   "\xA6","brvbar","\xA7","sect",
	"\xA8","uml",   "\xA9","copy",  "\xAA","ordf",  "\xAB","laquo",
	"\xAC","not",   "\xAD","shy",   "\xAE","reg",   "\xAF","macr",
	"\xB0","deg",   "\xB1","plusmn","\xB2","sup2",  "\xB3","sup3",
	"\xB4","acute", "\xB5","micro", "\xB6","para",  "\xB7","middot",
	"\xB8","cedil", "\xB9","sup1",  "\xBA","ordm",  "\xBB","raquo",
	"\xBC","frac14","\xBD","frac12","\xBE","frac34","\xBF","iquest",
	"\xC0","Agrave","\xC1","Aacute","\xC2","Acirc", "\xC3","Atilde",
	"\xC4","Auml",  "\xC5","Aring", "\xC6","AElig", "\xC7","Ccedil",
	"\xC8","Egrave","\xC9","Eacute","\xCA","Ecirc", "\xCB","Euml",
	"\xCC","Igrave","\xCD","Iacute","\xCE","Icirc", "\xCF","Iuml",
	"\xD0","ETH",   "\xD1","Ntilde","\xD2","Ograve","\xD3","Oacute",
	"\xD4","Ocirc", "\xD5","Otilde","\xD6","Ouml",  "\xD7","times",
	"\xD8","Oslash","\xD9","Ugrave","\xDA","Uacute","\xDB","Ucirc",
	"\xDC","Uuml",  "\xDD","Yacute","\xDE","THORN", "\xDF","szlig",
	"\xE0","agrave","\xE1","aacute","\xE2","acirc", "\xE3","atilde",
	"\xE4","auml",  "\xE5","aring", "\xE6","aelig", "\xE7","ccedil",
	"\xE8","egrave","\xE9","eacute","\xEA","ecirc", "\xEB","euml",
	"\xEC","igrave","\xED","iacute","\xEE","icirc", "\xEF","iuml",
	"\xF0","eth",   "\xF1","ntilde","\xF2","ograve","\xF3","oacute",
	"\xF4","ocirc", "\xF5","otilde","\xF6","ouml",  "\xF7","divide",
	"\xF8","oslash","\xF9","ugrave","\xFA","uacute","\xFB","ucirc",
	"\xFC","uuml",  "\xFD","yacute","\xFE","thorn", "\xFF","yuml",
    );

    local( $item, $char );
    foreach $item ( keys %array ) {
	foreach $char ( keys %en ) { $array{$item} =~ s/$char/&$en{$char};/gs; }
    }

    %array;			# return value for subroutine
}


sub print_html {
#   
# A simple subroutine to take care of HTTP headers and such for printing HTML.
# Here's where you'd add a HTTP response status message ("HTTP/1.0 200 OK")
# if your WinNT server requires it.
#
    local( $html ) = @_;

    print qq|Content-type: text/html\n\n|;
    print $html;

    undef;			# return value for subroutine
}


sub receive_form_information {
#
# Gets the form information and converts it into readable form
# (returns an associative array).
#
# global variable:      Creates '%FORM'
#
    local($buffer, @pairs, $pair, $name, $value);
    #
    # Get the input depending on how it is sent
    #
    if ( $ENV{'REQUEST_METHOD'} eq 'POST' ) {
	read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'} );
    }	# Otherwise we'll hope it's a GET
    else { $buffer = $ENV{'QUERY_STRING'}; }
    #
    # Split the name-value pairs depending on how they are encoded.
    # lynx 2.6 says it can now encode POST data as "sgml-form-urlencoded"
    #
    if ( $ENV{'CONTENT_TYPE'} eq 'application/sgml-form-urlencoded' ) {
	@pairs = split(/;/, $buffer);
    }	# otherwise we'll hope it's 'application/x-www-form-urlencoded'
    else { @pairs = split(/&/, $buffer); }

    foreach $pair (@pairs) {
	($name, $value) = split(/=/, $pair);
	#
	# This was lifted from the "doform.cgi" from the WN server
	# distribution (http://hopf.math.nwu.edu/) by John Franks
	#
	$value =~ tr/+/ /;
	$value =~ s/%([\da-f]{1,2})/pack(C,hex($1))/eig;

	$name =~ tr/+/ /;
	$name =~ s/%([\da-f]{1,2})/pack(C,hex($1))/eig;

	$FORM{ $name } .= "$value\t";		# multiple items are tabbed
    }
    foreach ( keys %FORM ) { chop $FORM{$_}; }	# lose the trailing tab

    %FORM;	# return value for subroutine
}


sub error {
#
# Fatal error messages can be simple, cryptic and ugly.
#
    local ( $error ) = @_;

    print "Content-type: text/plain\n\n";
    print "ERROR: $error\n";

    exit(1);
}

