Category: | CGI Programming |
Author/Contact Info | davido Dave Oswald |
Description: | poll.cgipoll.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:
That's about it. You can see a live version of this poll at: http://davido.perlmonk.org/cgi-bin/poll.cgiPlease 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 |
Back to
Code Catacombs