#!/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
[download]