File Coverage

blib/lib/HTML/Ballot/Trusting.pm

Criterion	Covered	Total	%
statement	13	33	39.3
branch	0	10	0.0
condition	0	6	0.0
subroutine	5	6	83.3
pod			n/a
total	18	55	32.7

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.


=head1 NAME

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

=head1 SYNOPSIS

# Create the poll

	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();

=head1 DESCRIPTION

A simple module for inseucre web ballots.

This is a very beta version that will mature over the
next week or so.  Please let me know how it breaks.

Features:

=over 4

=item *

no test is made of who is voting, so users may vote any number of
times, or may even vote (and surely will) thousands of times using a
"LWP" hack.

=item *

a HTML page of voting options and one of the results of votes so far
is generated from a single HTML template, and it is in these pages
that ballot status is maintained, so no additional file access is
required.

=item *

HTML output into the template is minimal, but all unique entities
are given a "class" attribute for easy CSS re-definitions.

=item *

simple bar charts of results are generated using HTML.

=item *

users may submit a comment with thier vote, though no connection
between the value of the vote and the user is recorded

=item *

users' IP addresses may be recorded, and displayed, and a chart
of the IP addresses from which communication has been received
the most may be displayed.

=back

In future these features may be added:

=over 4

=item *

A more secure version is being considered, which uses
simple e-mail authentication of users, sending ony one voting
password to any e-mail address: this may appear as
"HTML::Ballot::MoreCynical".

=item *

This may be extended to include a ballot `time out'.

=item *

Options to have graphs based on single-pixels, or using the "GD"
interface will arrive some time in the future.

=back

=head1 USE

=over 4

=item 1.

Construct an HTML template that can be used to generate the question
and answer pages.  Where you wish the questions and answers to
appear, insert the following element:



The template should at least define the CSS representation for
C and C as having a coloured background,
or you will not be able to view the results' bar graph.
See L for more details on other CSS classes
employed.

Other functions may be included as below. Note that Cs
may require some minimal content of at least a space character, I'm
not sure, I'd better check.

=over 4

=item *

If you wish to allow a user to submit a comment with their vote,
include the following element:


		This is what voter's have said:


Unlike the C, any text you include	in this
block will be reatained at the top of a list of users' comments.

=item *

If you wish to have the result page display a list of the names
entered by voters, also include:


		Here is the voterlist...


This acts in the manner of the C, above.

=item *

If you wish to have the result page display a list of the most
frequently-posting IP addresses, include:


		Top IP Addresses To Post To This Ballot


To this, the module will add a C of HTML that lists the
top posters.  Anything before that span (in this example,
the C element) will remain.

=back

=item 2.

Initiate the ballot by constructnig an HTML::Ballot::Trusting object and
calling C method upon it in a manner simillar to that described
in L.

In response, you should receive a list of the locations of files used and
dynamically created by the process.

=back

=head1 GLOBAL VARIABLES

Several global variables exist as system defaults.  Most may be over-riden
using the constructor (see the sections C, C,
C, C in L.>

=cut

#
# 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

=item IPCHART

THe number of items to include in the IP chart of frequent posters

=cut

our $IPCHART 		= 5;

=head1 CONSTRUCTOR (new)

Requires a reference to the class into which to bless, as well
as a hash (or reference to such) with the following key/value
content:

=over 4

=item ARTICLE_ROOT

the root, in the filesystem, where these HTML pages begin - can over-ride the global constant of the same name;

=item URL_ROOT

the root, on the internet, where these HTML pages begin - can over-ride the global constant of the same name;

=item QUESTIONS

an array of questions to use in the ballot

=item TPATH

Path at which the HTML Template may be found

=item QPATH

Path at which to save the HTML ballot Questions' page

=item RPATH

Path at which to save the HTML Results page

=item CPATH

If you do not use the C attribute (below), you must use this: Path at
which to save a dynamically-generated perl script that processes
form submissions. Obviously must be CGI accessible and CHMOD appropriately.

=item SUBMITTO

If you do not use the C attribute (above), you must use this:
Path to the script that processes submission of the CGI voting form

=item SHEBANG

Represents the Shebang line you place at the start of your perl scrpts:
set this to over-ride the default value taken from the global constant scalar
of the same name.  Could adjust this to suss the path from C or
even C, if it came to it, but time....

=item COMMENTLENGTH

Maximum acceptable length of text comments.

=item ASKNAMES

Set if users should supply their name when voting.

=item NAMELENGTH

If C (above) is defined, this value may be set to
limit the possible length of a name.

=back

=cut

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



=head1 METHODS

=head2 METHOD create

Creates the HTML voting page.

Accepts: just the calling object: all properties used should be set
during construction (see L).

If the page contains a C, will include a text box
in the voting page, to allow users to submit comments.  Setting
C to a value when calling the constructor will
restrict the length of acceptable comments.

If the page contains a , this will be updated
with the name supplied by the user.

Returns: the path to the saved HTML question document.

See also L and L.

=item QUESTION PAGE

The C attribute of the C element is set to the CGI
environment variable, C (that is, the location of this script).

Form elements are simply seperated by linebreaks (C): use CSS to control
the layout: the radio-button HTML elements are set to be class C;
the C button element is set to be class C.

=item RESULTS PAGE

HTML is used to create bar charts, but this should be easy to replace with
a C image, or a stretched single-pixel.  Each question is given a
C element, and results will be placed within by the C
method (see L).

See also L.

=cut

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 =	"
	$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 .= "$_\n";
	}
	$qhtml.="{RPATH}\">\n";

	# Add name input field if appropriate
	if (exists $self->{ASKNAMES}){
		$qhtml.="{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.="{COMMENTLENGTH}\" SIZE=\"40\">\n";
	}

	$qhtml.="\n\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 = "\n\n";
 \n\n\t";
 \n";
 \n";
 \n";
 \n";
 




412




 





 





 





 





 





 



 	foreach (@{$self->{QUESTIONS}}) {
 




413




 





 





 





 





 





 



 		$rhtml .= "$_




414




 





 





 





 





 





 



 		$rhtml .= "0




415




 





 





 





 





 





 



 		$rhtml .= "0%




416




 





 





 





 





 





 



 		$rhtml .= "No votes yet cast.




417




 





 





 





 





 





 



 		$rhtml .= "




418




 





 





 





 





 





 



 	}
 




419




 





 





 





 





 





 



 	$rhtml .= "\n\n";
	foreach (@{$self->{QUESTIONS}}) {
		$rhtml .= "
		$rhtml .= "
		$rhtml .= "
		$rhtml .= "
		$rhtml .= "
	}
	$rhtml .= "

	$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 "",$TEMPLATE->{TEMPLATEITEMS}->{COMMENT},"";
		$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 =<

$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;
}




=head2 METHOD cast_vote

Casts a vote and updates the results file.

Accepts:

1. the question voted for, as defined in the HTML vote form's C/C.

2. optionally, a user-submitted comment.

3. optionally, a user-submitted name.

=cut

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$_"} = '




534




 





 





 





 





 





 



 		if ($scores{$_} == $hi_score){
 




535




 





 





 





 





 





 



 			$template_items{"$STARTGRAPHIC$_"}.= 'class="votehighscorebar" ';
 




536




 





 





 





 





 





 



 		} elsif ($scores{$_}>0) {
 




537




 





 





 





 





 





 



 			$template_items{"$STARTGRAPHIC$_"}.= 'class="votebar" ';
 




538




 





 





 





 





 





 



 		}
 




539




 





 





 





 





 





 



 		$template_items{"$STARTGRAPHIC$_"}.= 'width="';
 




540




 





 





 





 





 





 



 		if ($scores{$_}==0){
 




541




 





 





 





 





 





 



 			$template_items{"$STARTGRAPHIC$_"}.='0%">';
 




542




 





 





 





 





 





 



 		} else {
 




543




 





 





 





 





 





 



 			$template_items{"$STARTGRAPHIC$_"} .= $pc;
 




544




 





 





 





 





 





 



 			$template_items{"$STARTGRAPHIC$_"}.= '%" ';
 




545




 





 





 





 





 





 



 			$template_items{"$STARTGRAPHIC$_"}.= 'bgcolor="red"' if exists $self->{NOCSS};
 




546




 





 





 





 





 





 



 			$template_items{"$STARTGRAPHIC$_"}.= '> ';
 




547




 





 





 





 





 





 



 		}
 




548




 





 





 





 





 





 



 		$template_items{"$STARTPC$_"} = sprintf("%.2f", $pc)."%";
 




549




 





 





 





 





 





 



 		$template_items{"$STARTGRAPHIC$_"}.= ''."\n";
		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$_"}.= '> ';
		}
		$template_items{"$STARTPC$_"} = sprintf("%.2f", $pc)."%";
		$template_items{"$STARTGRAPHIC$_"}.= '
	}
	# 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} .= "$todaydate$usrname$usrcomment\n";
	}

	# Include user's name
	if (exists $template_items{VOTERLIST}){
		$template_items{VOTERLIST}.="$usrname ";
	}
	# Include IP?
	if (exists $template_items{VOTERLIST}){
		$template_items{VOTERLIST}.="($ENV{REMOTE_HOST})";
	}
	# Finish user's name list
	if (exists $template_items{VOTERLIST}){
		$template_items{VOTERLIST}.="\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/.*//s;
		# Add the chart
		$template_items{IPCHART} .= '';
		my @ips = sort { $ips{$b} <=> $ips{$a} } keys %ips;
		for (0..$IPCHART-1){
			$template_items{IPCHART} .= "".($_+1).": $ips[$_]\n";
		}
		$template_items{IPCHART} .= '';
	}

	$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__