#!/usr/bin/perl

#  arach_bug_report.cgi reads a form and e-mails results

print "Content-type:text/HTML\n\n";

open(DATA,"../../email.cgi");
$recip_email = <DATA>;
chomp($recip_email);
close DATA;

# the first line of this script may have to be changed
# if your system's Perl interpreter is not located in /usr/bin/perl

# Written by P. Lutus Ashland, Oregon lutusp@arachnoid.com Saturday, March 29, 1997

$mailprog = "/usr/sbin/sendmail"; # change this name to the mail program on your system

$mailok = 0;

$local = ($ENV{'PERLXS'}); # identify a local test


$message = "";

if ($ENV{'REQUEST_METHOD'} eq 'POST') {
		read (STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
	@pairs = split(/&/, $buffer);
	$top = 0;
	foreach $pair (@pairs) {
		($name, $value) = split(/=/, $pair);
		
		$name =~ tr/+/ /;
		$name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
		$name =~ s/[&;`|*?<>^{}\[\]\$\n\r]//g; # filter metacharacters
		
		$value =~ tr/+/ /;
		$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
		$value =~ s/\r//g; # wipe out carriage returns
		$value =~ s/\n/\f/g; # replace linefeeds with formfeeds to not confuse the parser
		$value =~ s/[&;`|*?<>^{}\[\]\$]//g; # filter metacharacters
		
		$FORM{$name} = $value;
		$anams[$top] = $name;
		$avals[$top++] = $value;
	}
	# now test for validity

	local ($err) = (!($FORM{'email'} =~ /[\w|\.]+\@[\w|\.]+/)); # is this an e-mail address?

	if($err) {
		$message = "Invalid E-mail Address.<BR>";
	}
	elsif((!$FORM{'full_version'}) || ($FORM{'full_version'} ne "Yes")) {
			$message = "Please install the full version of Arachnophilia before submitting a bug report.<BR>";
		$err++;
	}
	else {
		foreach $f (keys %FORM) {
			if($FORM{$f} eq "") {
					$message .= "The information field <B>\"$f\"</B> has not been provided<BR>";
				$err++;
			}
		}
	}
	if(!$err) {
		$message = "<B>Thank you for submitting your bug report.</B>";
		send_mail($recip_email);
	}
	else { # submission error
		$message = "<B>Report submission error:</B><P>" . $message . "<P><I>You may return to the form by using your browser's \"back\" function</I>.";
	}
}
else { # cope with error
	$message = "Error: not submitted using POST.";
}

$data = readfile("arach_bugtemplate.html");

$data =~ s/\(BLOCK\)/$message/s; # insert the message into the template

print "Content-type: text/html\n\n$data"; # display the response page

exit;

sub send_mail { # mail to address in hidden "sendmail" field
	
	local ($addressee) = $_[0]; # I just love named variables.
	local ($print_format) = "%-24s = %s\n"; # set this up once and use it on all lines
	
	local ($sender) = $FORM{'email_address'};
	local ($mailok) = 0;
	
	if(!($sender =~ /[\w|\.]+\@[\w|\.]+/)) { # if not a valid e-mail address
		$sender = "nobody\@arachnoid.com";
	}
	if(($local) || (-e $mailprog)) { # if mailprog exists and is accessible
		#		if (open (MAIL, ">d:/temp2/mailtest.txt")) { # testing only
		if (open (MAIL, "|$mailprog $addressee")) {
			$mailok = 1;
			
			# This block is absorbed by sendmail >>
			
			print MAIL "To: $addressee\n";
			print MAIL "From: $sender\n";
			print MAIL "Reply-To: $sender\n";
			print MAIL "Subject: Arachnophilia bug report From $FORM{'name'}\n\n";
			
			# << sendmail block
			printf MAIL $print_format,"Date/Time",&readtime;
			
			foreach $f (keys %FORM) {
				if($f ne "bug_report") {
					if(substr($f,0,1) ne "!") {
						printf MAIL $print_format,$f,$FORM{$f};
					}
				}
			}
			$f = "bug_report";
			$FORM{$f} =~ s/\f/\n/g; # replace formfeeds with linefeeds so mail can stand it
			$q = "\n************************\n\n";
			$q .= $FORM{$f};
			$q .= "\n\n************************\n\n";
			
			foreach $f (sort (keys %FORM)) {
				if(substr($f,0,1) eq "!") {
					$q .= sprintf $print_format,substr($f,1),$FORM{$f};
				}
			}
			
			printf MAIL $print_format,$f,$q;
			close (MAIL);
		}
	}
	return $mailok;
}

sub readfile {
	local ($fn) = $_[0];
	local ($lineterm) = $/;
	undef $/; # allow reading an entire file at once
	open(DATA,$fn);
	if(!($fn =~ /\.htm\w*$/)) {
		binmode(DATA);
	}
	local $data = <DATA>;
	close DATA;
	$/ = $lineterm;
	return $data;
}

sub test_email_address { # test server using dns only -- other methods do not work
	local ($account,$server) = split("\@",@_[0]);
	if (test_hostname($server) == 0) { # if no error on bare host name
		return 0;
	}
	else { # try "www.hostname" form
		return test_hostname("www." + $server);
	}
}

sub test_hostname {
	gethostbyname($_[0]) || return 1; # error
	return 0; # no error
}

sub readtime {
	local (@wdnames) = ('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday');
	local (@mnames) = ('January','February','March','April','May','June','July','August','September','October','November','December');
	local ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
	return sprintf ("%s, %s %2.0f, %4.0f %2.0f:%02.0f:%02.0f"
	,$wdnames[$wday],$mnames[$mon],$mday,($year>50)?$year+1900:$year+2000, $hour,$min,$sec);
}