#!/usr/local/bin/perl

#  guestbook.cgi

# 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 -- July 30, 1997

# This script reads a web page form output and creates a guest book entry
# the field names are (in order, case-sensitive):
# name, email, homepage, pagename, reference, other, message
# this program currently requires name and email to have nonblank entries.
# call this program from a Web page form like this:
# <Form action="guestbook.cgi?Ownername" method="post">
#
# See my page at http://www.arachnoid.com/lutusp/guestbook/template.html for an example
#
# notice that you can have as many Ownername entries that you want, each creates its own guest book file.
#
# 8/20/96 modification. You can now send E-mail for each guestbook entry.
#
# if the variable $recipemail is nonblank,
# this script will automatically send e-mail to the specified address
# containing the data in the guest book entry.
#
# the directory in which this program is located must have world read and write permission,
# this Perl script must have world execute permission.
#
# Because this script uses sockets, the Perl resource file sockets.pm must be made available
# to the Perl interpreter.

$local = $ENV{'PERLXS'}; # only defined locally

if($local) { # local machine testing only
	$localhost = $ENV{'COMPUTERNAME'}; # only works on NT
	$remotehost = "pl_gamma.com";
	$recipname = "Paul Lutus";
	$recipemail = "test\@pl_gamma.com";
}
else {
# chop($localhost = `hostname`);
	$localhost = "arachnoid.com";
	$remotehost = "arachnoid.com";
	$recipname = "Paul Lutus";
	$recipemail = "lutus\@arachnoid.com";
}

$smtpPort = 25;

# reader section

$maxflds = 7; # fields in submission

$maxrecs = 25; # This program throws away any records older than $maxrecs, you can set any value

$recipient = "lutus\@arachnoid.com";

@blacklist = ( # people who cannot use the guestbook
);

#
# End user-defined values
#

$username = "Anonymous";

if($ENV{'QUERY_STRING'} ne "") {
		$username = $ENV{'QUERY_STRING'}; # the real mailbox owner
}

$title = "$username\'s Guest Book"; # the title block that appears in the output
$heading = "Please sign $username\'s Guest Book"; # the message block that appears in the output
$error1 = "";
$error2 = "";

@envname = ( # these are fields that are stored along with the visible message
	'REMOTE_ADDR',
	'REMOTE_HOST',
	'HTTP_REFERER',
	'HTTP_USER_AGENT',
	'HTTP_ACCEPT',
);

$mailok = 0;
$resetfields = 0;

test_entry();
make_page();

sub test_entry {
	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/~!/ ~!/g; # Stop people from using subshells to execute commands
			
			$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; # Stop people from using subshells to execute commands
			
			$FORM{$name} = $value;
			$allData .= " " . $value; # this is used for blacklist test
			$anams[$top] = $name;
			$avals[$top++] = $value;
		}
		if(!($FORM{'homepage'} =~ "http://")) {
				$FORM{'homepage'} = "http://" . $FORM{'homepage'};
		}
		$tempname = $username . ".tmp";
		$mbxname = $username . ".mbx";
		$testmsg = $FORM{'message'};
		$emailerr = (!($FORM{'email'} =~ /[\w|\.]+\@[\w|\.]+/)); # is this e-mail address?
		if(!$emailerr) {
			$emailerr = test_email_address($FORM{'email'}); # is the email address valid?
		}
		$htmlerr = ($testmsg =~ s/<.*>//isg); # HTML tags in message
		$blacklisterr = test_blacklist($allData);
		if((!$htmlerr)
				&& ($FORM{'message'} ne "")
				&& ($FORM{'name'} ne "")
				&& (!$emailerr) # valid entry must have these three nonblank
				&& (!$blacklisterr)) { # valid entry must have these three nonblank
				open (OUTPUT,">$tempname") || die "Can't open $tempname!";
			$dt = &readtime;
			print OUTPUT "$dt"; # first field is date and time
			for($i = 0;$i < $maxflds;$i++) {
				print OUTPUT "\t$avals[$i]";
			}
			foreach $envlbl (@envname) { # these special fields are not normally visible
				print OUTPUT "\t$ENV{$envlbl}";
			}
			print OUTPUT "\n";
			if(-e $mbxname) {
				open (INPUT,$mbxname);
				$r = 0;
				while(<INPUT>) {
					if($r < $maxrecs) { # This tosses old messages > $maxrecs
						print OUTPUT;
					}
					$r++;
				}
				close INPUT;
			}
			close OUTPUT;
			
# now move temp file onto mailbox file
			
			open(INDATA,"$tempname");
			undef $/;
			open (OUTDATA,">$mbxname");
			$q = <INDATA>;
			print OUTDATA $q;
			close INDATA;
			close OUTDATA;
			$/ = "\n";
			
# send mail if set up
			if($recipemail ne "") {
				
				setupSocket($localhost,$remotehost,$smtpPort);
				queryAndResp("",0);
				queryAndResp("HELO arachnoid.com",0);
				send_mail($FORM{'name'},$FORM{'email'},$recipname,$recipemail);
				queryAndResp("QUIT",0);
				close MAIL;
			}
			$heading = "Thanks for signing $username\'s Guest Book!";
		}
		else { # not enough entries
			if($htmlerr) {
				$heading = "Sorry!";
				$error1 .= "Your message contains HTML tags.";
				$error2 .= "Please submit a text-only message.";
			}
			elsif($emailerr) {
				$heading = "Sorry!";
				$error1 .= "You have not provided a valid e-mail address (or your ISP is not responding).";
				$error2 .= "Please provide more information.";
			}
			elsif($blacklisterr) {
				$heading = "Sorry!";
				$error1 .= "You have been blacklisted for misuse of this guestbook.";
				$error2 .= "Please e-mail <A href=mailto:lutusp\@arachnoid.com>lutusp\@arachnoid.com</A> if you believe this to be in error.";
			}
			else {
				$heading = "Sorry!";
				$error1 .= "You must enter at least your name, E-mail address and a message.";
				$error2 .= "Please provide more information.";
			}
			$resetfields = 1; # put field values back
		}
	}
} # end test_entry

# generator section

# This is the main routine that creates a web page from a guest book DB file

sub make_page {
	open(DATA,"template.html");
	undef $/;
	$data = <DATA>;
	close DATA;
	$/ = "\n";
	$block = makeblock($username);
	if($error1 ne "") {
		$error1 .= "<BR>";
	}
	if($error2 ne "") {
		$error2 .= "<BR>";
	}
	$data =~ s/\[messages\]/$block/s;
	$data =~ s/\[title\]/$title/s;
	$data =~ s/\[heading\]/$heading/s;
	$data =~ s/\[error1\]/$error1/s;
	$data =~ s/\[error2\]/$error2/s;
	if(!$resetfields) {
		undef %FORM;
		undef @FORM;
	}
	
	if(!$FORM{'homepage'}) { # make default entry
			$FORM{'homepage'} = "http://";
	}
	$data =~ s/\[namefield\]/$FORM{'name'}/s;
	$data =~ s/\[emailfield\]/$FORM{'email'}/s;
	$data =~ s/\[homepagefield\]/$FORM{'homepage'}/s;
	$data =~ s/\[pagenamefield\]/$FORM{'pagename'}/s;
	$data =~ s/\[otherfield\]/$FORM{'other'}/s;
	$msg = $FORM{'message'};
	$msg =~ s/\f/\n/g; # get back the linefeeds
	$data =~ s/\[messagefield\]/$msg/s;
	if(!$local) {
		print "Content-type:text/HTML\n\n";
	}
	print "$data\n";
}

# this is the subroutine that reads the database and converts it into HTML

sub makeblock {
	local ($user) = @_;
	@title = (
		"<Center><Font size=+2 Color=#FF8040><IMG src=\"../email_anim.gif\" alt=\"(letter animation)\">&nbsp;",
		"'s Guest Book Messages:</Font></Center><p>"
	);
	
	$table_head = "<Center><Table border=0 width=95%% >\n<tr><td>\n<Table>";
	
	@table_line = (
		"<tr><td><B><Font Color=#FFFF80>",
		"</Font></B></td><td><Font Color=#FFFFFF>",
		"</Font></td></tr>\n"
	);
	
	$table_tail = "</table></tr></td></table><BR><IMG src=\"../redchip.gif\" height=2 width=95%%><P>\n</Center>\n";
	
	@fieldname = (
		'Message Time',
		'Name',
		'E-mail Address',
		'Home Page',
		'Home Page Name',
		'How Found',
		'How Found',
		'Message'
	);
	
	$str_space = "&nbsp;&nbsp;&nbsp;";
	
	$char_tab = 9;
	$char_lf = 10;
	$char_ff = 12;
	
	$datablock = "";
	open(INPUT,"$user.mbx");
	while (<INPUT>) {
		chop; # throw out the last lf
		s/</&lt;/g; # replace all < with equivalent literal, this prevents embedded HTML entries
			s/>/&gt;/g; # replace all > with equivalent literal
			s/\f/<Br>/g; # replace all ff with <Br> tags
		@vals = split(/\t/); # split on tabs
		$datablock .= $table_head;
		for ($i = 0;$i < 8;$i++) {
			if(($i==2) && ($vals[$i] ne "")) {
				$datablock .= "$table_line[0]$fieldname[$i]:";
				if($vals[$i] ne "") {
					$datablock .= "$table_line[1]<A href=\"mailto:$vals[$i]\">$vals[$i]</A>";
				}
				$datablock .= $table_line[2];
			}
			elsif ($i==3)
			{
				if(($vals[$i] ne "") && ($vals[$i] ne "http://")) {
					$datablock .= "$table_line[0]$fieldname[$i]:";
					if($vals[$i+1] ne "") { # use provided name or link name if not
						$hpn = $vals[$i+1];
					}
					else {
						$hpn = $vals[$i];
					}
					if(($vals[$i] ne "") && (!($vals[$i] =~ /http:\/\//))) {
						$vals[$i] = "http://" . $vals[$i]; # must have prefix
					}
					$datablock .= "$table_line[1]<A href=\"$vals[$i]\" target=\"_top\">$hpn</A>";
					$datablock .= $table_line[2];
				}
				$i++; # an extra increment -- pass up the home page name
			}
			elsif($i == 5) {
				if(($vals[$i] ne "") && ($vals[$i] ne "Other - enter below")) {
					$datablock .= "$table_line[0]$fieldname[$i]:$str_space$table_line[1]$vals[$i]$table_line[2]\n";
				}
			}
			else {
				if($vals[$i] ne "") {
					$datablock .= "$table_line[0]$fieldname[$i]:$str_space$table_line[1]$vals[$i]$table_line[2]\n";
				}
			}
		}
		$datablock .= $table_tail;
	}
	close INPUT;
	return $datablock;
} # end makeblock

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);
	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); # on stack for return
}

sub send_mail { # mail to address in hidden "sendmail" field
	
	local ($fromname,$fromaddr,$toname,$toaddr) = @_; # I just love named variables.
	
	local $print_format = "%-24s = %s\n"; # set this up once and use it on all lines
	
	if(!($fromaddr =~ /[\w|\.]+\@[\w|\.]+/)) { # if not a valid e-mail address
		$fromaddr = "nobody\@arachnoid.com";
	}
	
	$fromaddr = "<$fromaddr>";
	$toaddr = "<$toaddr>";
	
	queryAndResp("MAIL From: $fromaddr",0);
	queryAndResp("RCPT To: $toaddr",0);
	queryAndResp("DATA",0);
	
	$dt = readtime();
	$message = "To: $toname $toaddr\n";
	$message .= "From: $fromname $fromaddr\n";
	$message .= "Subject: Guestbook Entry from $fromname\n\n";
	
	$message .= sprintf $print_format,"Date/Time",$dt;
	
	for($i = 0; $i < $maxflds;$i++) {
		if($anams[$i] eq "message") {
			
			$avals[$i] =~ s/\f/\n/g; # replace formfeeds with linefeeds so mail can stand it
			$avals[$i] =~ s/\n\./\n\.\./sg; # don't let terminating line through
			$avals[$i] = "\n\n************\n\n" . $avals[$i] . "\n\n************\n"; # dress up the message block
		}
		$message .= sprintf $print_format,$anams[$i],$avals[$i];
	}
	
	foreach $envlbl (@envname) { # these special fields are not normally visible
		$message .= sprintf $print_format,$envlbl,$ENV{$envlbl};
	}
	queryAndResp($message . "\n.\n",0);
}

sub test_blacklist {
	local($data) = @_;
	$blerr = 0;
	for $t (@blacklist) {
		$blerr ||= ($data =~ /$t/sig);
	}
	return $blerr;
}

sub test_email_address { # test using VRFY and RCPT as required
	
	local ($email) = @_[0];
	local ($account,$server) = split("\@",$email);
	local ($err) = setupSocket($localhost,$server,$smtpPort); # mormal form servername.com
	if($err) {
		$err = setupSocket($localhost,"mail\." . $server,$smtpPort);  # try mail.servername.com
		if($err) {
			$err = setupSocket($localhost,"smtp\." . $server,$smtpPort);   # try smtp.servername.com
			if($err) {
				return 1;
			}
		}
	}
	$mailerr = 0;
	queryAndResp("",0);
	queryAndResp("HELO arachnoid.com",0);
	queryAndResp("MAIL From: elvis\@graceland.com",0);
	local ($ckresp) = queryAndResp("RCPT To: $email",0); # non-relay sites will fail this call
	$mailerr = (!($ckresp =~ m/^250/));
	if($mailerr) {
		$ckresp = queryAndResp("VRFY $email",0); # non-verify sites will fail this call
		$mailerr = (!($ckresp =~ m/^250/));
	}
	queryAndResp("QUIT",0);
	close MAIL;
	return $mailerr;
}

sub setupSocket { # local host, remote host, port
	use Socket;
	my($localhost,$remote,$port) = @_;
	my($iaddr, $paddr, $proto, $line, $output);
	
	$sockaddr = 'S n a4 x8';
	
	if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') }
		return 1 unless $port;
	
	($name,$aliases,$addrtype,$length,@alladdr) = gethostbyname($localhost) || return 1;
	
	$thisaddr = $alladdr[$#alladdr]; # use last on list -- usually assigned address
	
	$thataddr = gethostbyname($remote) || return 1;
	
	$this   = pack($sockaddr, AF_INET, 0, $thisaddr);
	$that   = pack($sockaddr, AF_INET, $port, $thataddr);
	$proto   = getprotobyname('tcp');
	socket(MAIL, PF_INET, SOCK_STREAM, $proto)  || return 1;
	bind(MAIL, $this) || return 1;
	connect(MAIL, $that) || return 1;
	
	select(MAIL);
	$| = 1;
	select(STDOUT);
	return 0;
}

sub queryAndResp {
	local ($query,$multi) = @_;
	if($query ne "") {
		print MAIL "$query\n";
	}
	$data = "";
	local $inline;
	do {
		$inline = <MAIL>;
		$inline =~ s/[\r|\n]//g; # remove all cr/lf chars
		$data .= $inline . "\n";
	}
	while(($multi) && ($inline ne ".")); # multi-line terminator
	return $data;
}

sub trace {
	local ($tracedata) = @_[0];
	open (DATA,">>temp.txt");
	print DATA "$tracedata\n";
	close DATA;
	print "Content-type:text/plain\n\n$tracedata\n";
}