Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl Monk, Perl Meditation
 
PerlMonks  

CGI Poll Generator / Tracker

by davido (Cardinal)
on Sep 29, 2003 at 08:26 UTC ( #294909=sourcecode: print w/replies, xml ) Need Help??
Category: CGI Programming
Author/Contact Info davido Dave Oswald
Description:

poll.cgi

poll.cgi is a self-contained web poll script. It doesn't require any external HTML to work. Just install it per the instructions below, and you're off to the races. The interface is plain vanilla, but the implementation is fairly complete and (I think) well thought out. Only one caviet: Not for win32.

The following script runs a basic web poll. The Q&A format is pretty flexible, allowing for true/false, or any number of multiple choice poll responses. Here's what you need to know:

  • This script reads the poll's questions and possible answers from its own __DATA__ section. However, if you wish, at the top of the script change $question_file from its current empty string to the actual relative path to an alternate question file. The script will detect that change and will try to read the questions and answers in from the alternate question file.
  • The Q&A file (or <DATA> section) format is as follows:

    • First line of the file must be the poll's title. After that.......
    • Lines starting with # will be ignored.
    • Blank lines or lines with nothing but whitespace will be ignored.
    • Start a question off with a 'Qn: ' at the start of the line, where 'n' is the question number or ID, followed by the actual question text.
    • Each line containing an answer should start with 'A: ', followed by the answer's ID (must be unique within the current question, but it's not necessary that it be unique within the entire poll), followed by the answer's text, each segment delimited by whitespace. The answer text, of course, may contain whitespace as part of the text. In general, useless whitespace (extra spaces between fields, etc.) will be eliminated when the questions and answers are read in.
    • Each question/answer set must end with a line containing 'E' as the first (preferably only) character on that line.
    • See the __DATA__ section of the script for an example.
  • To use the script you must create an empty file, world read/writeable somewhere where the script may access it. The default path is "../polldata/poll.dat". You may edit the variable, $poll_data_path, located at the top of the script to change the relative location of the poll datafile. For security through obscurity (not terribly secure) I recommend making the ../polldata/ directory unreadable to the outside world (and unwritable, of course). The script knows where the file is within that directory, no need to let others see too.
  • The poll's output data file (poll.dat) will grow with each poll submission. Keep that in mind. This script is fine for a couple thousand respondents, but if you get into tens of thousands this script is not terribly efficient of either time or disk space. For heavy duty applications you'll have to rework how the results are stored. If you look at the inline comments you'll understand why I did it the way I did.
  • By entering a valid userID and password and clicking the "Enter" button, you will gain access to the page that displays the poll results. While in testing the userID is 'Guest' and the password is also 'Guest'. Note, this security is not really all that secure. It is intended to deter casual snoopers. You may edit the variables $userid and $adminpass at the top of the script to use your own username/password.

That's about it.

You can see a live version of this poll at: http://davido.perlmonk.org/cgi-bin/poll.cgi

Please let me know what you think of it... especially if it's suggestions for improvement. Here's the source....

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

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://294909]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others making s'mores by the fire in the courtyard of the Monastery: (10)
As of 2021-01-20 11:11 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    Notices?