#!/usr/bin/perl # SurveySays Version 2.0 # Copyright 1998-2002 by Matt Riffle All Rights Reserved. # Initial Full Release: 7/4/98 This Release: 6/21/02 # pingPackets http://www.pingpackets.com/ # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 2 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. It is included in # this distribution in the file "LICENSE". # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA # 02111-1307, USA. # Some standard modules -- don't edit these use strict; use CGI qw/header param/; use Fcntl ':flock'; # This is the path to the data file the script will use to store results. # The script must either have permissions to write to the directory the # file will be stored in (and it will create the file itself on first run), # or you can create the file yourself (as a 0-byte file), and just give # the script permission to write to the file. my $DATAFILE = "/home/mark-0/cgi_data/survey/bilboreunion/data.txt"; # This is the path to another file that the web server can open. This will # be used as a "semaphore" for file-locking to ensure the integrity of the # data file. my $SEMAPHORE = "/home/mark-0/cgi_data/survey/bilboreunion/semaphore.txt"; # This is the path to a temporary directory the script can use to write out # results first. You can set it to "" if you'd like, but using the # temporary directory increases the safety of your data. my $TMP_DIR = "/tmp"; # This is the URL needed to call the script directly. my $SCRIPT_URL = "/survey/bilboreunion/surveysays.cgi"; # This is a code that is unique among all your SurveySays scripts. It is # used as the name of the optional voting cookie, as well as for telling # which poll is being voted on. It should be short, alphanumeric, and # unique from other instances of this script. my $POLL_CODE = "poll/survey/bilboreunion"; # This is the "name" of your poll. It should only be a few words long. my $POLL_NAME = "SpenceMusic Bilbo Reunion"; # These variables control the look of your poll. $TOP_COLOR is the color # at the top of the poll, where the $POLL_NAME will be. $BOT_COLOR is the # color of the bottom of the poll. $FONT_COLOR is the color the text will # be, and $FONT_SIZE is how big it will be. $FONT_FACE controls the font # that is used by the poll. $TABLE_WIDTH controls how wide your poll will # be (I recommend keeping the default values as given for $FONT_SIZE and # $TABLE_WIDTH). my $TOP_COLOR = "#FF0000"; my $FONT_FACE="Arial,Helvetica"; my $BOT_COLOR = "#ffffff"; my $FONT_COLOR = "#0000FF"; my $FONT_SIZE = "-2"; my $TABLE_WIDTH = "125"; # This variable is the question you are asking in your poll. my $QUESTION = "Assuming money was not a problem, time off from work was agreed, baby-sitters were sorted, etc. Would you go to a reunion gig of Bilbo Baggins?"; # @CHOICES represents the possible answers people can give. It should # be formatted as shown. my @CHOICES = ("Yes","No","Don't Know"); # If $GRAPHICAL is set to 1, a 'bar graph' of sorts will be printed along # side percentages when the results are shown (set it to 0 to report only # percentages). If used, $GR_FILE is the URL to call the "dot" that is # used to create the bars (feel free to replace the default purple one). # $GR_HEIGHT is the height in pixels the bar should be, and $GR_SCALE helps # control the width (when set to 1, an answer with 25% of the vote would # have a bar 25 pixels wide; if set to 2, 25% would yield a 50 pixel bar # and so on). my $GRAPHICAL = 1; my $GR_FILE = "dot.gif"; my $GR_SCALE = 1; my $GR_HEIGHT = 10; # There are several ordering options for displaying results. If this # variable is set to 'given' they will be ordered as they are in @CHOICES. # If set to 'low' they will be ordered from low to high. If set to 'high' # they will be ordered from high to low (which is also the default). my $SORT_RESULTS_BY = 'high'; # If you want the total number of votes received to be reported with the # results, set this to 1. Else, set it to 0. my $REPORT_TOTAL_VOTES = 1; # If you'd like to only display results after a certain number of votes are # cast, set this variable that number. Set it to 0 (zero) if you'd like to # always display the results. my $SHOW_VOTES_AFTER = 0; # The script has two ways of checking for people who have already voted. One # way is by setting a cookie. The other is by keeping track of the IP # addresses votes are cast from. To use both, set this variable to 'all'. To # use cookies only, set it to 'cookie'. To use IPs only, set it to 'ip'. I # recommend setting it to 'all' -- neither method is 100% effective, but the # combination of them is pretty good. my $CHECK_BY = 'all'; # This variable should be set to the number of IP addresses to remember, if # using IP checking. I recommend between 5 and 10. my $IPS_CACHED = 10; # If you are using cookies, the following two variables must be set. # $COOKIE_REALM should likely be ".example.com" using your domain name. # $COOKIE_DAYS should be set to the number of days to wait before the # cookie expires. my $COOKIE_REALM = ".spencemusic.co.uk"; my $COOKIE_DAYS = 45; # If the browser doesn't send the "HTTP_REFERER" variable, which is pretty # common, the script won't know by default where to redirect to. Setting # this to the URL that the poll is viewed at allows the script to continue # working. my $PANIC_URL = "http://www.spencemusic.co.uk/survey/bilboreunion/surveysays.cgi"; # This variable, if set to 1, may help alleviate problems with browsers and # proxy servers caching your page and not displaying poll results. my $SUPPRESS_CACHE = 1; # This variable, if set to 1, adds a text link to the poll, which # allows the user to see the poll results without voting. my $WITHOUT_VOTE = 1; # Once you are done with a poll, you can set $ARCHIVE to 1 so that the poll # only returns results when called, and cannot be voted on. Note that this # is ridiculously inefficient -- you should simply load the poll, save the # HTML code, and use that. However, people wanted it, so here it is. my $ARCHIVE = 0; # Do Not Edit Below This if (open ICONF,"< survey.conf") { my @options; while () { chomp; next unless $_; my ($name,$value)=split " ",$_,2; if (lc($name) eq "name") { $POLL_NAME=$value; } elsif (lc($name) eq "question") { $QUESTION=$value; } elsif (lc($name) eq "option") { push @options,$value; } } @CHOICES=@options if @options; close CONF; } surveysays(); exit; sub surveysays { initialize_data(); # Handle absence of HTTP_REFERER if possible if (!$ENV{HTTP_REFERER} && $PANIC_URL) { $ENV{HTTP_REFERER} = $PANIC_URL } # get form parameters my $f = get_params(); # If person has already voted, return results check_for_vote(); # Results only, if that's what was requested return_results('only') if $ENV{QUERY_STRING} =~ /show_results/; # Take Care of the Vote, if any register_vote($f) if $ENV{QUERY_STRING} eq $POLL_CODE; # If none of the above, return quiz return_quiz(); } sub initialize_data { lock_data(LOCK_EX) or error("Couldn't lock file"); unless (-z $DATAFILE || !-e $DATAFILE) { unlock_data(); return; } open(FILE,">$DATAFILE") or error('Error writing file'); print FILE 'CHOICES|||'; for (my $i = 1; $i <= scalar(@CHOICES); $i++) { print FILE '0'; print FILE '|||' unless ($i == scalar(@CHOICES)); } print FILE "\nIPS|||"; for (my $i = 1; $i <= $IPS_CACHED; $i++) { print FILE '0.0.0.0'; print FILE '|||' unless ($i == $IPS_CACHED); } close(FILE); unlock_data(); } sub check_for_vote { return_results() if $ARCHIVE; lock_data(LOCK_SH) or error("Couldn't lock file"); open(FILE,"<$DATAFILE") or error('Error opening file'); chomp(my $totals = ); chomp(my $ips = ); close(FILE); unlock_data(); my ($check1,@totals) = split(/\|\|\|/,$totals); my ($check2,@ips) = split(/\|\|\|/,$ips); # Error Checking error('Data file corrupted') unless ($check1 eq 'CHOICES' && $check2 eq 'IPS'); my $voted; # ip check if ($CHECK_BY =~ /(ip|all)/ && $IPS_CACHED > 0) { for my $ip (@ips) { $voted++ if $ip eq $ENV{REMOTE_ADDR}; } } # cookie check if ($CHECK_BY =~ /(cookie|all)/) { my $cgi = new CGI; $voted++ if ($cgi->cookie($POLL_CODE) eq 'voted'); } return_results() if $voted; } sub register_vote { my $f = shift; # get the lock lock_data(LOCK_EX) or error("Couldn't lock file"); # get the current data open(FILE,"<$DATAFILE") or error('Error opening data file'); chomp(my $totals = ); chomp(my $ips = ); close(FILE); my ($check,@totals) = split(/\|\|\|/,$totals); my ($check2,@ips) = split(/\|\|\|/,$ips); shift @ips while scalar(@ips) >= $IPS_CACHED; # Error Checking error('Data file corrupted') unless $check eq 'CHOICES'; error('Number of choices has changed') unless scalar(@CHOICES) == scalar(@totals); # Count the vote $totals[$f->{quiz}-1]++ if defined($totals[$f->{quiz}-1]); # write the new data file my $write_file = ($TMP_DIR) ? "$TMP_DIR/$$" . time . ".ss" : $DATAFILE; open(FILE,">$write_file") or error('Error writing file'); print FILE 'CHOICES|||', join('|||',@totals), "\n"; print FILE 'IPS|||', join('|||',@ips), "|||$ENV{REMOTE_ADDR}"; close(FILE); # Copy file if we used a temp one if ($TMP_DIR) { system("/bin/mv","-f",$write_file,$DATAFILE) and error('Error replacing data file') } # unlock file unlock_data(); # Cache Supression Code my $add_on = ($SUPPRESS_CACHE) ? '?survey' . int(rand(99999)) : ''; # Return to page print "Location: $ENV{HTTP_REFERER}$add_on\n"; # Try to set cookie if desired if ($CHECK_BY =~ /^(cookie|all)$/) { my $cgi = new CGI; $COOKIE_DAYS = 60 if $COOKIE_DAYS =~ /\D/; my $cookie = $cgi->cookie(-name => $POLL_CODE, -value => 'voted', -expires => "+${COOKIE_DAYS}d", -path => '/', -domain => $COOKIE_REALM); print $cgi->header(-cookie=>$cookie); } print "\n"; exit; } sub return_quiz { lock_data(LOCK_SH) or error("Couldn't lock file"); open(FILE,"<$DATAFILE") or error('Error opening data file'); chomp(my $totals = ); close(FILE); unlock_data(); my ($check, @totals) = split (/\|\|\|/,$totals); # Error Checking error('Data file corrupted') unless $check eq 'CHOICES'; error('Number of choices has changed') unless scalar(@CHOICES) == scalar(@totals); # Return Table print header, table_top(), < END for (my $i = 1; $i <= scalar(@CHOICES); $i++) { print "$CHOICES[$i-1]
"; } print <
END if ($WITHOUT_VOTE) { print <[ View Results ] END } print table_bottom(); exit; } sub return_results { my $arg = shift; lock_data(LOCK_SH) or error("Couldn't lock file"); open(FILE,"<$DATAFILE") or error('Error opening data file'); chomp(my $totals = ); close(FILE); unlock_data() or error('Error unlocking file'); my ($check, @totals) = split (/\|\|\|/,$totals); # Error Checking error('Data file corrupted') unless $check eq 'CHOICES'; error('Number of choices has changed') unless scalar(@CHOICES) == scalar(@totals); my ($mastertotal,@processed); for (my $i = 0; $i < scalar(@CHOICES); $i++) { $mastertotal += $totals[$i]; push(@processed,"$totals[$i]|||$CHOICES[$i]"); } if ($SORT_RESULTS_BY eq 'low') { @processed = sort {$a <=> $b} (@processed); } elsif ($SORT_RESULTS_BY ne 'given') { @processed = sort {$b <=> $a} (@processed); } print header, < $POLL_NAME $QUESTION

\n END if ($mastertotal < $SHOW_VOTES_AFTER) { print <
END } print "$what: $percent\%
\n"; } if ($REPORT_TOTAL_VOTES) { print "

Total Votes: $mastertotal
\n"; } if ($arg eq 'only') { print < END } print table_bottom(); exit; } sub table_top { return < $POLL_NAME $QUESTION

END } sub table_bottom { # The GPL says you can do what you want, so comment the credit out if you # must. It's not much of a "customization" though. return <

by Morley Enterprises END } sub error { print header, table_top(), "[Error: ", shift, "]

", table_bottom(); exit; } sub get_params { my $f; for my $key (param()) { $f->{$key} = join (' ',param($key)) } return $f; } { local *SEM; sub lock_data { my $type = shift; open(SEM,">$SEMAPHORE") or return undef; flock(SEM,$type) or return undef; return 1; } sub unlock_data { close(SEM); } }