HTML::Ballot::Trusting - HTML-template-based insercure multiple-choice ballot

	use HTML::Ballot::Trusting;
	$HTML::Ballot::Trusting::CHAT = 3;
	my $p = new HTML::Ballot::Trusting {
		ARTICLE_ROOT => 'E:/www/leegoddard_com',
		URL_ROOT 	=> 'http://localhost/leegoddard_com',
		RPATH 	 => 'E:/www/leegoddard_com/vote/results.html',
		TPATH	 => 'E:/www/leegoddard_com/vote/template.html',
		QPATH	 =>	'E:/www/leegoddard_com/vote/vote.html',
		CPATH 	 => 'E:/www/leegoddard_com/CGI_BIN/vote.pl',
		ASKNAMES => 1,
		QUESTIONS => [
			'Why?',
			'Why not?',
			'Only for £300.'
		]
	};
	$p->create();

package HTML::Ballot::Trusting;
our $VERSION = 0.2;		# Thu Jul 26 15:03:11 2001
use strict;
use warnings;
use Carp;
use HTML::Entities ();

# Later: CGI and use HTML::EasyTemplate 0.985;


our $CHAT = undef;		# Set for reports to STDERR.

#
# These defaults can be over-ridden by using their
# names as values in the hash passed to the constructor
#
our $ARTICLE_ROOT 	= 'E:/www/leegoddard_com';
our $URL_ROOT 		= 'http://localhost/leegoddard_com';
our $STARTGRAPHIC 	= "STARTGRAPHICHERE__";
our $STARTPC		= "STARTPCHERE__";
our $SHEBANG		= '';
our $ASKNAMETEXT	= 'Your name, please';
our $ASKCOMMENTTEXT	= 'Optionally, your comment optional';
our $MAXTOTALCOMMENTLENGTH = 2000000;	# Maxium size of all comment mark up permitted

our $IPCHART 		= 5;

sub new {
	my $class = shift or die "Called without class";
	my %args;
	my $self = {};
	bless $self,$class;

	# Default instance variables
	$self->{ARTICLE_ROOT} 	= $ARTICLE_ROOT;
	$self->{URL_ROOT} 		= $URL_ROOT;
	$self->{COMMENTLENGTH}	= 75;
	$self->{NAMELENGTH}		= 30;

	# Take parameters and place in object slots/set as instance variables
	if (ref $_[0] eq 'HASH'){	%args = %{$_[0]} }
	elsif (not ref $_[0]){		%args = @_ }

	# Overwrite default instance variables with user's values
	foreach (keys %args) { $self->{uc $_} = $args{$_} }
	undef %args;

	# Calling-paramter error checking
	croak "Template path TPATH does not exist" if exists $self->{TPATH} and not -e $self->{TPATH};
	croak "No RPATH" if not exists $self->{RPATH} and not defined $self->{RPATH};

	return $self;
} # End sub new

sub create { my $self = shift;
	local *OUT;
	my %template_items;
	my $form_processing_url ;
	croak "No path to HTML template" if not exists $self->{TPATH} or not defined $self->{TPATH};
	croak "No path to save HTML at" if not exists $self->{QPATH} or not defined $self->{QPATH};
	croak "No questions" if not exists $self->{QUESTIONS} or not defined $self->{QUESTIONS};
	if ((not exists $self->{SUBMITTO} or not defined $self->{SUBMITTO})
	and (not exists $self->{CPATH} or not defined $self->{CPATH})){
		croak "No SUBMITTO or CPATH value defined - one or the other is required"
	}

	use HTML::EasyTemplate 0.985;

	# Create question poll page QPATH #############################################
	#
	# Create radio button HTML from questions
	my $TEMPLATE = new HTML::EasyTemplate(
		{	ADD_TAGS => 1,
			SOURCE_PATH => $self->{TPATH},
			ARTICLE_ROOT => $self->{ARTICLE_ROOT},
			URL_ROOT => $self->{URL_ROOT},
		});
	$TEMPLATE -> process('collect');					# Collect the values

	# Where should the form ACTION point? Set now so can use TEMPLATE methods
	if (exists $self->{CPATH}){
		$form_processing_url = $TEMPLATE->set_article_url($self->{CPATH});
	} else {
		$form_processing_url = $self->{SUBMITTO}
	}

	# Construct form
	my $qhtml =	"<form name=\"".__PACKAGE__."\" method=\"post\" action=\"$form_processing_url\" ";
	$qhtml .= "onSubmit=\"";
	$qhtml .= "if (this.usrcomment.value=='$ASKCOMMENTTEXT'){this.usrcomment.value=''}";
	$qhtml .= "if (this.usrname.value==''){alert('Please, please, please enter your name.... it will not be recorded against your vote');this.usrname.focus();return false;}";
	$qhtml .= "if (this.usrname.value=='$ASKNAMETEXT'){alert('Please enter your name.. It will not be recorded against your vote');this.usrname.focus();return false;}";
	$qhtml .= "return true;";
	$qhtml .= "\">\n";

	foreach (@{$self->{QUESTIONS}}) {
		$_ = HTML::Entities::encode($_);
 		$qhtml .= "<input class=\"voteoptionradio\" type=\"radio\" name=\"question\" value=\"$_\"><SPAN class=\"voteoptiontext\">$_</SPAN></input><BR>\n";
	}
	$qhtml.="<INPUT type=\"HIDDEN\" name=\"rpath\" value=\"$self->{RPATH}\">\n";

	# Add name input field if appropriate
	if (exists $self->{ASKNAMES}){
		$qhtml.="<INPUT name=\"usrname\" value=\"$ASKNAMETEXT\" onFocus=\"this.value=''\" class=\"votenametextbox\" type=\"TEXT\" MAXLENGTH=\"$self->{NAMELENGTH}\" SIZE=\"40\">\n";
	}

	# Add comment input field if comment output area is defined:
	if (exists $TEMPLATE->{TEMPLATEITEMS}->{COMMENT} and defined $TEMPLATE->{TEMPLATEITEMS}->{COMMENT}){
		$qhtml.="<INPUT name=\"usrcomment\" value=\"$ASKCOMMENTTEXT\" onFocus=\"this.value=''\" class=\"votecommenttextbox\" type=\"TEXT\" MAXLENGTH=\"$self->{COMMENTLENGTH}\" SIZE=\"40\">\n";
	}

	$qhtml.="<INPUT type=\"SUBMIT\" class=\"voteoptionsubmit\" value=\"Cast Vote\">\n</FORM>\n";
	$template_items{QUESTIONS} 	= $qhtml;				# Make new values, for example:
	$TEMPLATE -> process('fill', \%template_items );	# Add them to the page
	$TEMPLATE -> save($self->{QPATH});

	# Create initial results page RPATH template ####################################
	#
	my $rhtml = "<DIV class=\"voteresults\">\n<TABLE width=\"100%\">\n";
	foreach (@{$self->{QUESTIONS}}) {
		$rhtml .= "<TR>\n<TD class=\"votequestion\" align=\"left\" nowrap width=\"25%\">$_</TD>\n\t";
		$rhtml .= "<TD class=\"votescore\" align=\"right\"><TEMPLATEITEM name=\"$_\">0</TEMPLATEITEM></TD>\n";
		$rhtml .= "<TD class=\"votepc\" nowrap align=\"right\"><TEMPLATEITEM name=\"$STARTPC$_\">0%</TEMPLATEITEM></TD>\n";
		$rhtml .= "<TD class=\"chart\" width=\"75%\" align=\"left\"><TEMPLATEITEM name=\"$STARTGRAPHIC$_\">No votes yet cast.</TEMPLATEITEM></TD>\n";
		$rhtml .= "</TR>\n";
	}
	$rhtml .= "</TABLE>\n</DIV>\n";

	$TEMPLATE = new HTML::EasyTemplate(
		{	ADD_TAGS => 1,
			SOURCE_PATH => $self->{TPATH},
			ARTICLE_ROOT => $self->{ARTICLE_ROOT},
			URL_ROOT => $self->{URL_ROOT},
		});
	$TEMPLATE -> process('collect');					# Collect the values

	$template_items{QUESTIONS} 	= $rhtml;				# Make new values, for example:

	if (exists $TEMPLATE->{TEMPLATEITEMS}->{COMMENT} and defined $TEMPLATE->{TEMPLATEITEMS}->{COMMENT}){
		#die "<XMP>",$TEMPLATE->{TEMPLATEITEMS}->{COMMENT},"</XMP>";
		$template_items{COMMENT} = $TEMPLATE->{TEMPLATEITEMS}->{COMMENT};
	}
	if (exists $TEMPLATE->{TEMPLATEITEMS}->{VOTERLIST}){
		$template_items{VOTERLIST} =  $TEMPLATE->{TEMPLATEITEMS}->{VOTERLIST};
	}
	# Add IP chart if requested
	if (exists $TEMPLATE->{TEMPLATEITEMS}->{IPCHART} ){
		$template_items{IPCHART} = $TEMPLATE->{TEMPLATEITEMS}->{IPCHART}
	}
	$TEMPLATE -> process('fill', \%template_items );	# Add them to the page
	$TEMPLATE -> save($self->{RPATH});

	# Create the script to submit the form ##########################################
	# Could have this sciprt's functionality within the module, checking for CGI
	# param on every calling, and that may be more economical, but is less clean.
	$_ = scalar __PACKAGE__;
	my $Perl =<<EOPERL;

$SHEBANG
\# Caller script located at $self->{CPATH} ($form_processing_url)
\# Dynamically generated by and for $_ :: create

use HTML::Ballot::Trusting;
use CGI;
our \$cgi = new CGI;
if (\$cgi->param() and \$cgi->param('question') and \$cgi->param('rpath') ){
	\$v = new HTML::Ballot::Trusting ( {RPATH=>\$cgi->param('rpath')});
	\$v->cast_vote( \$cgi->param('question'),\$cgi->param('usrcomment'),\$cgi->param('usrname') );
} else {print "Location: $form_processing_url\\n\\n\\n";}
exit;

EOPERL

	open OUT, ">$self->{CPATH}" or croak "Could not open <$self->{CPATH}> for writing";
	print OUT $Perl;
	close OUT;

	# Report #######################################################################
	print "Created poll.\n",
		"Calling-script at: $self->{CPATH}\n",
		"HTML template at: $self->{TPATH}\n",
		"Qustion HTML is at: $self->{QPATH}\n",
		"Results HTML is at: $self->{RPATH}\n\n";

	return 1;
}

sub cast_vote { my ($self, $q_answered,$usrcomment,$usrname) = (shift,shift,shift,shift);
	croak "No object" if not defined $self;
	croak "No answer" if not defined $q_answered;
	croak "No RPATH" if not exists $self->{RPATH};
	croak "No RPATH path to save results at" if not exists $self->{RPATH};

	@_ = split/ /,(scalar localtime); # Create the date
	my $todaydate = "$_[2] $_[1] $_[4] $_[3]";

	# Get existing results
	my $TEMPLATE = new HTML::EasyTemplate(
		{	ADD_TAGS => 1,
			SOURCE_PATH => $self->{RPATH},
			ARTICLE_ROOT => $self->{ARTICLE_ROOT},
			URL_ROOT => $self->{URL_ROOT},
			FLOCK => 1,
		});
	$TEMPLATE -> process('collect');						# Collect the values
	my %template_items = %{$TEMPLATE->{TEMPLATEITEMS}};		# Do something with them

	my %scores;												# Keyed by question
	my ($total_cast,$hi_score) = (0,0);
	# Aquire results from template
	foreach (keys %template_items){
		if ($_!~/^(VOTERLIST|IPCHART|COMMENT|\Q$STARTGRAPHIC\E|\Q$STARTPC\E)/ and $_ ne 'QUESTIONS'){
			$template_items{$_}++ if $_ eq $q_answered;
			$scores{$_} = $template_items{$_}; # Will create a warning, not-numeric, but works...:(
			$total_cast += $scores{$_};
			$hi_score = $scores{$_} if $scores{$_} > $hi_score;
		}
	}
	# Create new results
	foreach (keys %scores){
		warn "$_...$template_items{$_}\n" if $CHAT;
		my $pc = ((100 / $total_cast) * $template_items{$_} );
		$template_items{$_} = $scores{$_};
		$template_items{"$STARTGRAPHIC$_"} = '<TABLE width="100%"><TR><TD ';
		if ($scores{$_} == $hi_score){
			$template_items{"$STARTGRAPHIC$_"}.= 'class="votehighscorebar" ';
		} elsif ($scores{$_}>0) {
			$template_items{"$STARTGRAPHIC$_"}.= 'class="votebar" ';
		}
		$template_items{"$STARTGRAPHIC$_"}.= 'width="';
		if ($scores{$_}==0){
			$template_items{"$STARTGRAPHIC$_"}.='0%">';
		} else {
			$template_items{"$STARTGRAPHIC$_"} .= $pc;
			$template_items{"$STARTGRAPHIC$_"}.= '%" ';
			$template_items{"$STARTGRAPHIC$_"}.= 'bgcolor="red"' if exists $self->{NOCSS};
			$template_items{"$STARTGRAPHIC$_"}.= '>&nbsp;';
		}
		$template_items{"$STARTPC$_"} = sprintf("%.2f", $pc)."%";
		$template_items{"$STARTGRAPHIC$_"}.= '</TD><TD></TD></TR></TABLE>'."\n";
	}
	# Include user's comments
	if (defined $usrcomment and $usrcomment!~/^\s*$/g
	and length $template_items{COMMENT}<$MAXTOTALCOMMENTLENGTH		# No overstuffing of the file
	){
		$usrcomment = substr $usrcomment,$self->{COMMENTLENGTH} if length $usrcomment>$self->{COMMENTLENGTH};
		$usrcomment = HTML::Entities::encode($usrcomment);
		$template_items{COMMENT} .= "<DIV class=\"comment\"><SPAN class=\"votecommentdate\">$todaydate</SPAN><SPAN class=\"voteusrname\">$usrname</SPAN><SPAN class=\"votecommenttext\">$usrcomment</SPAN></DIV>\n";
	}

	# Include user's name
	if (exists $template_items{VOTERLIST}){
		$template_items{VOTERLIST}.="<SPAN class\"listvoteusrname\"><SPAN class=\"voteusrname\">$usrname </SPAN>";
	}
	# Include IP?
	if (exists $template_items{VOTERLIST}){
		$template_items{VOTERLIST}.="<SPAN class=\"voteusrip\">($ENV{REMOTE_HOST})</SPAN>";
	}
	# Finish user's name list
	if (exists $template_items{VOTERLIST}){
		$template_items{VOTERLIST}.="</SPAN>\n";
	}
	# Top-X IPs
	if (exists $template_items{IPCHART}){
		# Collect IP addresses from VOTERLIST
		my %ips;
		while ($template_items{VOTERLIST} =~ m/\QSPAN class="voteusrip">(\E(127.0.0.1)\Q)<\/SPAN>\E/g){
			$ips{$1}++;
		}
		# Remove previous chart (as defined below) from page
		$template_items{IPCHART} =~ s/<SPAN class="ipchart">.*//s;
		# Add the chart
		$template_items{IPCHART} .= '<SPAN class="ipchart">';
		my @ips = sort { $ips{$b} <=> $ips{$a} } keys %ips;
		for (0..$IPCHART-1){
			$template_items{IPCHART} .= "<SPAN class=\"ipchartitem\">".($_+1).": $ips[$_]</SPAN>\n";
		}
		$template_items{IPCHART} .= '</SPAN>';
	}

	$TEMPLATE -> process('fill', \%template_items );		# Add them to the page
	$TEMPLATE -> save($self->{RPATH});
	# Redirect
	print "Location: $TEMPLATE->{ARTICLE_PATH}\n\n";
	return 1;
}



1;
__END__