#!/usr/local/bin/perl -T
# poll.cgi: Creates an HTML form containing a web poll (or
# questionaire).
use strict;
use warnings;
use CGI::Pretty;
use CGI::Carp qw( fatalsToBrowser );
# ------------------ Begin block ------------------------------------
# This script uses the BEGIN block as a means of providing CGI::Carp
# with an alternate error handler that sends fatal errors to the
# browser instead of the server log.
BEGIN {
sub carp_error {
my $error_message = shift;
my $cq = new CGI;
print $cq->start_html( "Error" ),
$cq->h1("Error"),
$cq->p( "Sorry, the following error has occurred: " ),
$cq->p( $cq->i( $error_message ) ),
$cq->end_html;
}
CGI::Carp::set_message( \&carp_error );
}
# ----------------- Script Configuration Variables ------------------
# Script's name.
my $script = "poll.cgi";
# Poll Question filehandle.
# Questions will be read from <DATA>. Unset $question_fh if
# you wish to read from an alternate question file.
my $question_fh = \*DATA;
# Poll Question File path/filename.
# Set $question_file to the path of alternate question file.
# Empty string means read from <DATA> instead of an external file.
+
my $question_file = "";
# Set path to poll tally file. File must be readable/writable by all.
# For an added degree of obfuscated security ensure that the file's
# directory is not readable or writable by the outside world.
my $poll_data_path = "../polldata/poll.dat";
# Administrative User ID and Password. This is NOT robust.
# It prevents casual snoopers from seeing results of poll.
my $adminpass = "Guest";
my $userid = "Guest";
# -------------------- File - scoped variables ----------------------
# Create the CGI object:
my $q = new CGI;
# -------------------- Main Block -----------------------------------
MAIN_SWITCH: {
my $poll_title;
# If the parameter list from the server is empty, we know
# that we need to output the HTML for the poll.
!$q->param() && do {
$poll_title = print_poll( $question_fh,
$question_file,
$script,
$q );
last MAIN_SWITCH;
};
# If the user hit the "Enter" submit button, having supplied a
# User ID and Password, he wants to see the poll's tally page.
defined $q->param('Enter') && do {
if ( $q->param("Adminpass") eq $adminpass and
$q->param("Userid" ) eq $userid ) {
my $results = get_results ( $poll_data_path );
print_results( $question_fh,
$question_file,
$results,
$q );
} else {
action_status("NO_ADMIN", $poll_title, $q);
}
last MAIN_SWITCH;
};
# If the user hit the "Submit" submit button, having answered
# all of the poll's questions, he wants to submit the poll.
defined $q->param('Submit') && do {
if ( verify_submission( $q ) ) {
write_entry( $poll_data_path, $q );
action_status("THANKS", $poll_title, $q);
} else {
$q->delete_all;
action_status("INCOMPLETE", $poll_title, $q);
}
last MAIN_SWITCH;
};
# If we fall to this point it means we don't know *what* the
# user is trying to do (probably supplying his own parameters!
action_status("UNRECOGNIZED", $poll_title, $q);
}
$q->delete_all; # Clear parameter list as a last step.
# We're done! Go home!
# -------------------- End Main Block -------------------------------
# -------------------- The workhorses (subs) ------------------------
# Verify the poll submission is complete.
# Pass in the CGI object. Returns 1 if submission is complete.
# Returns zero if submission is incomplete.
sub verify_submission {
my $q = shift;
my $params = $q->Vars;
my $ok = 1;
foreach my $val ( values %$params ) {
if ( $val eq "Unanswered" ) {
$ok = 0;
last;
}
}
return $ok;
}
# Write the entry to our tally-file. Entry consists of a series of
# sets. A set is a question ID followed by its answer token.
# Pass in the path to the tally file and the CGI object.
# Thanks tye for describing how an append write occurs as an
# atomic entity, thus negating the need for flock if entire record
# can be output at once (at least that's what I think you told me).
sub write_entry {
my ( $outfile, $q ) = @_;
my $output="";
my %input = map { $_ => $q->param($_) } $q->param;
foreach (keys %input) {
$output .= "$_, $input{$_}\n" if defined $input{$_};
}
open POLLOUT, ">>$outfile"
or die "Can't write to tracking file\n$!";
print POLLOUT $output;
close POLLOUT or die "Can't close tracking file\n$!";
}
# Read and tabulate results of poll entries from the data file.
# Results are tabulated by adding up the number of times each
# answer token appears, for each question.
# Pass in filename. Returns a reference to a hash of hashes
# that looks like $hash{question_id}{answer_id}=total_votes.
sub get_results {
my $datafile = shift;
my %tally;
open POLLIN, "<$datafile"
or die "Can't read tracking file.\n$!";
while (my $response = <POLLIN> ) {
chomp $response;
my ( $question, $answer ) = split /,\s*/, $response;
$tally{$question}{$answer}++;
}
close POLLIN;
return \%tally;
}
# Output a results page to the browser. Reads the original
# question file (or DATA) to properly associate the text of the
# questions and answers with the tags stored in the tally hash.
# Pass in the q-file filehandle, the q-file name (blank if <DATA>),
# the reference to the tally-hash, and the CGI object.
sub print_results {
my ( $fh, $qfile, $tally, $q ) = @_;
if ( $qfile ) {
$fh = undef;
open $fh, "<".$qfile or die "Can't open $qfile.\n$!";
}
my $script_url = $q->url( -relative => 1 );
my $title = <$fh>;
chomp $title;
$title .= "Results";
print $q->header( "text/html" ),
$q->start_html( $title ),
$q->h1( $title ),
$q->p;
while ( my $qset = get_question( $fh ) ) {
print "Question: $qset->{id}: $qset->{question}:<br><ul>";
foreach my $aset ( @{$qset->{'answers'}} ) {
if ( exists $tally->{$qset->{id}}{$aset->{token}} ) {
print "<li>$aset->{text}: ",
"$tally->{$qset->{id}}{$aset->{token}}.";
}
}
print "</ul><p>"
}
if ( $qfile ) {
close $fh or die "Can't close $qfile.\n$!";
}
print $q->hr,
$q->p( "Total Respondents: ",
"$tally->{'Submit'}{'Submit'}." ),
$q->hr,
$q->p( "<a href=$script_url>Return to poll</a>"),
$q->end_html;
}
# Outputs the HTML for the poll.
# Pass in the filehandle to the poll's question file,
# its filename (empty string if <DATA>), script name,
# and CGI object.
sub print_poll {
my ( $fh, $infile, $scriptname, $q ) = @_;
if ( $infile ) {
$fh = undef;
open $fh, "<".$infile or die "Can't open $infile.\n$!";
}
my $polltitle = <$fh>;
chomp $polltitle;
print $q->header( "text/html" ),
$q->start_html( -title => $polltitle),
$q->h1( $polltitle ),
$q->br,
$q->hr,
$q->start_form( -method => "post",
-action => $scriptname );
while ( my $qset = get_question( $fh ) ) {
my ( %labels, @vals );
foreach ( @{$qset->{'answers'}} ) {
push @vals, $_->{'token'};
$labels{ $_->{'token'} } = $_->{'text'};
}
push @vals, "Unanswered";
$labels{'Unanswered'} = "No Response";
print $q->p( $q->h3( $qset->{'question'} ) ),
$q->radio_group(
-name => $qset->{'id'},
-default => "Unanswered",
-values => \@vals,
-labels => \%labels,
-linebreak => "true" );
}
print $q->p, $q->p,
$q->submit( -name => "Submit" ),
$q->reset,
$q->endform,
$q->br,
$q->p,
$q->p,
$q->hr,
$q->start_form( -method => "post",
-action => $scriptname ),,
$q->p($q->h3("Administrative use only.") ),
$q->p( "ID: ",
$q->textfield( -name =>"Userid",
-size => 25,
-maxlength => 25 ),
"Password: ",
$q->password_field( -name => "Adminpass" ),
$q->submit( -name => "Enter" ) ),
$q->endform,
$q->end_html;
if ( $infile ) {
close $fh or die "Can't close $infile.\n$!";
}
return $polltitle;
}
# Outputs an HTML status page based on the action requested.
# This routine is used to thank the user for taking the poll, or
# to blurt out user-caused warnings.
# Pass in the action type, poll title, and the CGI object.
sub action_status {
my ( $action, $title, $q ) = @_;
print $q->header( "text/html" ),
$q->start_html( -title => $title." Status" ),
$q->h1( $title." Status" ),
$q->hr;
my ( $headline, @text, $script_url );
$script_url = $q->url( -relative => 1 );
RED_SWITCH: {
$action eq 'NO_ADMIN' && do {
$headline = "Access Denied";
@text = ( "This section is for administrative ",
"use only.<p>",
"<a href = $script_url>Return to poll.</a>" );
last RED_SWITCH;
};
$action eq 'THANKS' && do {
$headline = "Thanks for taking the poll.<p>";
@text = ( "" );
last RED_SWITCH;
};
$action eq 'INCOMPLETE' && do {
$headline = "Error: You must answer all poll questions.";
@text = ( "Please complete poll, and submit again.<p>",
"<a href = $script_url>Return to poll.</a>"
+ );
last RED_SWITCH;
};
$action eq 'UNRECOGNIZED' && do {
$headline = "Error: Unrecognized form data.";
@text = ( "" );
last RED_SWITCH;
};
}
print $q->h3( $headline ),
$q->p( @text ),
$q->end_html;
}
# Gets a single question and its accompanying answer set from
# the filehandle passed to it.
# Returns a structure containing a single Q/A set. A poll will
# generally consist of a number of Q/A sets, so this function
# is usually called repeatedly to build up the poll.
sub get_question {
my $fh = shift;
my ( $question_id, $question, @answers, %set );
GQ_READ: while ( my $line = <$fh> ) {
chomp $line;
GQ_SWITCH: {
$line eq "" && do { next GQ_READ }; # Ignore blank.
$line =~ /^#/ && do { next GQ_READ }; # Ignore comments.
$line =~ /^Q/ && do { # Bring in a question.
die "Multiple questions\n"
if $question_id or $question;
( $question_id, $question ) = $line =~
/^Q(\d+):\s*(.+?)\s*$/;
last GQ_SWITCH;
};
$line =~ /^A/ && do { # Bring in an answer.
my ( $token, $text ) = $line =~
/^A:\s*(\S+)\s*(.+?)\s*$/;
die "Bad answer.\n" unless $token and $text;
push @answers, {( 'token' =>$token,
'text'=>$text )};
last GQ_SWITCH;
};
$line =~ /^E/ && do { # End input, assemble structure.
die "Set missing components.\n"
unless $question and @answers;
$set{'id'} = $question_id;
$set{'question'} = $question;
$set{'answers'} = \@answers;
last GQ_SWITCH;
};
}
return \%set if %set;
}
return 0; # This is how we signal nothing more to get.
}
# -------------------- <DATA> based poll ----------------------------
# First line of DATA section should be the Poll title.
__DATA__
Dave's Poll
# Format: Comments allowed if line begins with #.
# Blank lines allowed.
# Data lines must begin with a tag: Qn:, A:, or E.
# Any amount of whitespace separates answer tokens from text.
# Other whitespace is not significant.
# Complete sets must be Qn, A:, A:...., E.
# If you choose to use an external question file, comment out
# but retain as an example at least one question from below.
Q1: Does the poll appear to work?
A: ++++ Big Success!
A: +++ Moderate Success!
A: ++ Decent Success!
A: + Success!
A: - Minor Unsuccess.
A: -- Some Unsuccess.
A: --- Moderate Unsuccess.
A: ---- Monumental Disaster!
E
Q2: Did you find serious issues?
A: !! Yes, serious!
A: ! Yes, minor.
A: * Mostly no.
A: ** Perfect!
E
Q3: Regarding this poll:
A: +++ You could take it over and over again all day!
A: ++ Kinda nifty.
A: + Not bad.
A: - Yawn...
A: -- Zzzzzzz....
A: --- Arghhhhh, get this off my computer!
E
Q4: You spend too much time on the computer.
A: T True.
A: F False.
A: H Huh?
E
Q5: You're sick of answering questions.
A: ++ Definately.
A: + Somewhat.
A: - Bring them on!
E
|
