#! /usr/bin/perl

# sm.pl -- a state machine CGI based engine (in perl)
# $Id: sm.pl,v 1.3 1999/12/07 05:56:02 cgd Exp cgd $
# Carlos Duarte <cgd@mail.teleweb.pt>, 990626

##
# how to use this: 
# . if the cgi is named "foo.pl". then there should be a dir named "foo"
#   with all used html files in it
# . each invocation of this script, sees a LINKFROM variable, and a 
#   function with that name is run...
# . except for first call, where default() is called (or if LINKFROM is invalid)
# . each called function should return the next state (i.e. html page 
#   to show next, and the function to run after it)
# . html_subst(xxx) = value, will replace all <!--xxx--> per value (case sens)
# . form_hidden(xxx) = value, will add input variable xxx=value to each form
# . the special combination <!--LOOP_START-->...<!--LOOP_STOP-->, will 
#   replace all tags in "..." repeatedly, until tag variable are empty
#   (each tag with multiple values is separated per "\0")
# 

use strict; 

use CGI; 

defined &die_catcher and $SIG{__DIE__} = \&die_catcher; 

my %form_hidden; 		# for gen_page
my %html_subst;  		# for gen_page
my $cgi = new CGI;

my (
	$self_dir, 		# full path of this file, with no filename
	$self_file, 		# filename of this file (with no path)
	$self_base, 		# filename with no extension
	$self_href 		# valid callself href
) = get_self_info(); 

########################################################################
## persistent vars: those will travel between all cgi invocations 
## cgi -> html via hidden; html -> via param
## 
use vars qw($year ); 
my @global_vars = qw(year ); 

########################################################################
## main: get vars, run action func, and generate page
## 
{
	for (@global_vars) { eval "\$$_=\$cgi->param('$_');"; }
	my $linkfrom = $cgi->param('LINKFROM'); 
	my $linkto; 

	if (is_ok($linkfrom)) {
		eval "\$linkto = $linkfrom();"; 
	} else {
		$linkto = default(); 
	}

	for (@global_vars) { eval "\$form_hidden{'$_'}=\$$_; "; }
	$form_hidden{'LINKFROM'} = $linkto;
	gen_page("$self_dir/$self_base/$linkto.html",
				\%form_hidden, \%html_subst);
}

exit; 

########################################################################
## aux functions -- dont need changes

# get info about this cgi location
sub get_self_info {
	my $dir = $ENV{PWD};
	my $file = $0;		$file =~ s#^.*/##; 
	my $base = $file;	$base =~ s#\.[^.]*$##; 

	my $href = $cgi->script_name(); 
	$href eq "" and $href = $ENV{SCRIPT_NAME};
	$href eq "" and $href = "/cgi-bin/$file"; 

	$dir eq ""  and $dir = "."; 
	return ($dir, $file, $base, $href); 
}

# quotes special html symbols
sub hquote {
	local $_ = shift;
	s/\&/&amp;/g;
	s/\</&lt;/g;
	s/\>/&gt;/g;
	s/\"/&quot;/g;
	return $_; 
}

# filename, \%hidden, \%subst
# 	replaces all <!--xx--> on subst, and introduce input type=hidden
# 	variable defined in hidden on filename
# 
sub gen_page {
	local ($_,$.,$/); 
	my $fn = shift; 
	my %hid = %{ scalar shift };
	my %subst = %{ scalar shift }; 
	local *F; 

	undef $/; 
	open F, $fn or die "can't open $fn: $!"; 
	$_ = <F>;
	close F; 

	# add input type=hidden variables... 
	my $r; 
	for my $k (keys %hid) {
		$r .= '<input type=hidden name="'; 
		$r .= hquote($k); 
		$r .= '" value="'; 
		$r .= hquote($hid{$k}); 
		$r .= '">'."\n"; 
	}
	s#(<form.*?)>#$1 method=post action='$self_href'>#sig; 
	s#</form>#\n$r\n$&#sig; 

	# handle loops
	my $temp; 
	while (s/^(.*?)<!--:?LOOP_START-->(.*?)<!--:?LOOP_STOP-->//s) {
		$temp .= $1; 
		my $tt = $2;   ## body of loop
		
		for (;;) {
			my $at_least_one=0; 
			my $t = $tt; 
			$t =~ s/<!--(:?)(\w+)-->/do {
				my $r; 
				my $p = index($subst{$2}, "\0"); 
				if ($p == -1) {
					$r = $subst{$2};
					$subst{$2} = ""; 
				} else {
					$r = substr($subst{$2}, 0, $p); 
					$subst{$2} = substr($subst{$2}, $p+1); 
				}
				$r ne ""  and $at_least_one++; 
				$1 eq ":" and $r = hquote($r); 
				$r; 
			}/seg or last; 
			$at_least_one or last; 
			$temp .= $t; 
		}
	}
	$temp .= $_; 	# left overs

	# handle <!--tags--> 
	$temp =~ s/<!--(:?)(\w+)-->/do {
		my $r = $subst{$2}; 
		my $p = index($r, "\0"); 
		$p != -1 and $r = substr($r, 0, $p); 
		$1 eq ":" and $r = hquote($r); 
		$r; 
	}/seg; 

	print $cgi->header; 
	print $temp; 
}

# quote binary data to AABB... where AA is two hex digits of first char, etc..
sub _q {
	local $_ = shift; 
	s/./sprintf("%02x",ord($&))/seg; 
	return $_; 
}

# unquote AABB... to binary
sub _uq {
	local $_ = shift; 
	s/../chr(hex($&))/seg; 
	return $_; 
}

########################################################################
## USER FUNCTIONS, defaults should be ok

# $subject, $message, @whom
sub sendmail {
	local $_; 
	my $mail;
	local *MM; 
	my $subj = shift; 
	my $mess = shift; 

	$_ = `uname`; 
	if (/^linu/i) {
		$mail = "mail"; 
	} else {
		$mail = "mailx"; 
	}

	my $guys = join ' ', @_; 
	$subj =~ s/'/'\\''/g; 
	# if this fails, what else can go wrong?!?
	open MM, "|$mail -s '$subj' $guys";  
	$mess =~ s/(^|\n)~/$1~~/sg;  ## escape the ~ commands
	print MM $mess; 
	print MM "\n----\n"; 
	print MM "Date: ", scalar localtime, "\n"; 
	print MM "Cgi:  ", $self_href, "\n"; 
	close MM; 
}

# catch our dies... 
sub die_catcher {
	my $msg = shift; 

	print $cgi->header;
	print<<EOM;
<html> <head> <title> Failure page </title> </head> <body> 
<p>
<b> Failure: $msg </b> 

<tt> 
<pre> 
Date: ${\(scalar localtime)}
Cgi: $self_href
</pre>
</tt>

</body> </html>
EOM

	## this will also send mail to someone responsabile
	#my $s = $msg; 
	#$s =~ s/^\s*//s; $s =~ s/\n.*$//; 
	#length($s) > 72 and $s = substr($s, 0, 72); 
	#sendmail($s, $msg, 'operacoes@teleweb.pt'); 

	exit; 
}

# validate if FUNC can be called, as defined per LINKFROM
# return 1 if yes, 0 if not
#
sub is_ok {
	my $func = shift; 

	# func must exist 
	defined &$func or return 0; 

	# must have a file .html with the same name 
	return 0 unless ( -f "$self_dir/$self_base/$func.html" ); 

	## more checks (return 0 on fail)

	return 1; 
}

# to cumulate errors:		_err(msg); 
# then, to flag the error:	_err() and return _err(); 
#
my (@_err, $_err); 
sub _err {
	if (@_) {
		push @_err, @_; 
		return; 
	}
	$_err==0 and return $_err = !!@_err; 
	return _error(@_err); 
}

# if there is an user error (invalid data, for instance), use: 
# 	return _error(reason1, ...); 
#
sub _error {
	local $_; 

	# save state -- subst and hidden information
	for (keys %form_hidden) {
		$form_hidden{"hidden_".$_} = _q $form_hidden{$_}; 
		delete $form_hidden{$_};
	}
	for (keys %html_subst) {
		$form_hidden{"subst_".$_} = _q $html_subst{$_}; 
		delete $html_subst{$_};
	}

	# setup error message
	for (@_) { 
		$html_subst{'ERRORMSG'} .= "$_\0"; 
	}

	$form_hidden{'LINKSAVE'} = $cgi->param('LINKFROM'); 
	return "error"; 
}

# a more or less general error action 
sub error {
	local $_; 
	for ($cgi->param()) {
		my $val = $cgi->param($_);

		if (s/^hidden_//) { $form_hidden{$_} = _uq $val; next; }
		if (s/^subst_//) { $html_subst{$_} = _uq $val; next; }
	}
	return scalar $cgi->param('LINKSAVE');
}

########################################################################
## USER CODE 
##
## convention: xxx() for states, and _xxx() for actions that gen data for xxx()
##

sub default {
	return "first"; 
}

sub first {
	$html_subst{'year'} = $year;  ### on error, this must be loaded
	$year =~ /^\d+$/ or return _error("$year: bad year specification"); 
	$html_subst{'output'} = `cal $year`; 
	return "cal"; 
}

sub cal {
	$html_subst{'year'} = $year; 
	return "first"; 
}