#!/usr/local/bin/perl 

# ======================================================================
# write-form.pl  
#
# Takes information from a form and writes it to a file somewhere. 
#
# Call this program with e.g. ACTION="/cgi-bin/write-form?mailing-list" 
# where "mailing-list" is the alias of the file to be written to.
# Aliases are in file.list.
#
#
# Original code by
# Carlos A. Pero (cpero@ncsa.uiuc.edu)
#
# Adapted as a generic forms handler by 
# Marco Falcioni falcioni@npac.syr.edu)  Aug 1995 and
# Paul Coddington (paulc@npac.syr.edu) Sep 1995
#
# ======================================================================



########################################################################
########## Configurable variables ######################################

########## Nothing else to change ######################################
########################################################################


$SCRIPT = $ENV{'SCRIPT_NAME'};

#### Do standard HTTP stuff ####
&cgi_receive;
&cgi_decode;
&cgi_header;

#### Call this program with ACTION="/cgi-bin/write-form?mailing-list" 
# where "mailing-list" is the alias of the file to be written to.
# Aliases are in file.list.
$FORM{'writefile'} = $ENV{'QUERY_STRING'};

#### Lookup write file 
open (WRITEFILES, "file.list") || die ("$SCRIPT: Can't open file.list: $!\n");
while (<WRITEFILES>) {
    chop;
    ($alias, $addr) = split(/:/, $_);
    $ADDRESS{$alias} = $addr;
}
close (WRITEFILES);
&error_blank_field('the nickname of the recipient') unless ($ADDRESS{$FORM{'writefile'}});


#### Append information to the output file
$writefile = $ADDRESS{$FORM{'writefile'}};
open (OUTPUTFILE, ">>$writefile") || 
  die ("$SCRIPT: Can't open $writefile: $!\n");
&dump_values(FORM, OUTPUTFILE);
print OUTPUTFILE "\n";
close (OUTPUTFILE);
chmod (0664, $writefile);

#### Now, redirect if "next-url" is included
if ($FORM{'next-url'}) {
    print "Location: $FORM{'next-url'}\n";
    print "\n";
    exit;
}

#### Output confirmation message ####
print qq|<HTML><HEAD><TITLE>Acknowledgement of receipt of information
</TITLE></HEAD><BODY>\n|;
print "<H2> $FORM{'subject'} </H2><HR>\n";
print "The following information has been recorded:\n";
print "<PRE>\n";
print "\n";
    &dump_values(FORM, STDOUT);
print "\n";
print "</PRE>\n";
print "</BODY>\n";
print "</HTML>\n";
exit;


#####################################################################
#### SUBROUTINES ####################################################

sub error_blank_field {
    local($variable) = @_;
    print "\n" if ($FORM{'next-url'});
    print "<HTML><HEAD><TITLE>Server-Email Error</TITLE></HEAD><BODY>\n";
    print "<H1>Error!</H1>\n";
    print "You did not fill in $variable.\n";
    print "Please go back to the form and do so.\n";
    print "</BODY>\n";
    exit;
}

sub cgi_header {
    print "Content-type: text/html\n";
    print "\n" unless ($FORM{'next-url'});
}        

sub cgi_receive {
    if ($ENV{'REQUEST_METHOD'} eq "POST") {
        read(STDIN, $incoming, $ENV{'CONTENT_LENGTH'});
    }
    else {
        $incoming = $ENV{'QUERY_STRING'};
    }
}

sub cgi_decode {
    @pairs = split(/&/, $incoming);

    foreach (@pairs) {
        ($name, $value) = split(/=/, $_);

        $name  =~ tr/+/ /;
        $value =~ tr/+/ /;
        $name  =~ s/%([A-F0-9][A-F0-9])/pack("C", hex($1))/gie;
        $value =~ s/%([A-F0-9][A-F0-9])/pack("C", hex($1))/gie;

        #### Strip out semicolons unless for special character
        $value =~ s/;/$$/g;
        $value =~ s/&(\S{1,6})$$/&\1;/g;
        $value =~ s/$$/ /g;

        $value =~ s/\|/ /g;
        $value =~ s/^!/ /g; ## Allow exclamation points in sentences

        #### Skip blank text entry fields
        next if ($value eq "");

        #### Check for "assign-dynamic" field names
        #### Mainly for on-the-fly input names, especially checkboxes
        if ($name =~ /^assign-dynamic/) {
            $name = $value;
            $value = "on";
        }

	#### Allow for multiple values of a single name
        $FORM{$name} .= ", " if ($FORM{$name});

        $FORM{$name} .= $value;
    }
}

sub dump_values {
    local($env, $handle) = @_;
    local(%PAIRS);
    local($format);
    local($value);

    %months = (Jan,"01",
	       Feb,"02",
	       Mar,"03",
	       Apr,"04",
	       May,"05",
	       Jun,"06",
	       Jul,"07",
	       Aug,"08",
	       Sep,"09",
	       Oct,"10",
	       Nov,"11",
	       Dec,"12");

    require "ctime.pl";

    ($day,$month,$num,$time,$year)= split(" ",&ctime(time));
    ($hour,$min,$sec)= split(":",$time);
    $year =~ s/19//;
#    if ($num < 10)  {$num = "0$num"};
    $mon = $months{$month};
#
# Here I build a unique reference number for the order in question
# it is composed by the year - month - day - hours - mins - sec 
# hence it has a very very small probability of not being unique 
#    
    $refkey = "$year$mon$num$hour$min$sec";

    eval "\@keys = keys \%$env";
    eval "\@values = values \%$env";
    while ($#keys >= 0) {
	$key = pop(@keys);
	$value = pop(@values);
	$PAIRS{$key}=$value;
    }
    ($handle eq "STDOUT") && (print $handle "<PRE>\n");

#    print $handle "$FORM{'subject'}","\n";
    if ($FORM{'Reference Key'} eq "YES") {
      # print $handle "-" x 70,"\n";
      print $handle "Reference Key: ",$refkey,"\n";
      # print $handle "-" x 70,"\n";
    }
    $format = "%s: %s\n";
    foreach( sort keys(%PAIRS)){
	$value = $PAIRS{$_};
	if(/^[A,B,C]/){		# print only interesting fields
	    if($value eq "BEGINS"){ # switch to listing format
		$format = "%s: %s ";
		print $handle "-" x 70,"\n";
	    } elsif($value eq "ENDS") {	# switch back to regular format
		$format = "%s: %s\n";
		print $handle "-" x 70,"\n";
	    } else {
		$_ =~ s/^.*-//;	# strip the leading sort info
		printf $handle $format,$_,$value;
		$_ eq "Price" && print $handle "\n"; # ugly workaround
	    }
	}
    }
    ($handle eq "STDOUT") && (print $handle "</PRE>\n");
}


