#!/usr/bin/perl

#-----------------------------------------------------------#
#
# BNBSURVEY Script 3.0, (C)2000 Bignosebird.com 
# Use of this script means that you accept the disclaimer and
# agree to the terms of use located at the bottom of the
# script.
#
# This script is provided without support. Please read the
# README.TXT file, as well as following the troubleshooting
# links and information at http://bignosebird.com/cgi.shtml
# Our BBS is located at http://bignosebird.com/bbs.shtml
# 
# Additional security patch added 12-30-2000 in decode
# subroutine.
#
#------------SCRIPT CONFIGURATION SECTION--------------------

# The script can be called in this manner to provide view without
# voting:

# http://domain.com/cgi-bin/survey/survey.cgi?survey_name=number1


# $DATA_PATH is the FULL system path to the directory where
# your survey data files are stored. Your web server must have
# permission to write to and create files in this directory

  $DATA_PATH="/www/schappenings/htdocs/cgi-bin/survey";

# The $DOMAIN must be your site's domain name. 

  $DOMAIN="www.schappenings.com";

# $GRAPHICSDIR is the directory under your main html directory
# containing the colored gif files.

  $GRAPHICSDIR="survey/images";
 
# To prevent people from voting too often, set $USE_COOKIES=1
# HOURS is the NUMBER OF HOURS before the voter can vote
# again. 1 Day=24, 1 Week=168, 1 Month=720 give or take....
# To disable cookies, let $USE_COOKIES=0
#
# WARNING: DO NOT ENABLE COOKIES UNTIL YOU ARE SURE EVERYTHING
# IS WORKING PERFECTLY, OR YOUR DEBUGGING CAN BE SERIOUSLY
# SLOWED DOWN WHILE YOU WAIT FOR THE COOKIE TO EXPIRE. ;-) 

  $USE_COOKIES=1;
  $HOURS=5;  # one hour delay between votes

# Set $USE_LOGGING to 1 to turn on log file capture.
# Log format is an ASCII tab delimited file consisting of:
# Visitor's IP address, date, time, responses, e-mail, comments
# Can be easily imported into spreadsheets and databases

  $USE_LOGGING=1;

# IF $SHOW_RESULTS=0 (do not display after voting), be sure
# to set $JUMP_URL to the page the voter should be sent to.
# By default, it sends the voter back to the page they came from.
# When used with SHOW_RESULTS=1, this is the link they can click
# on after viewing the voting.

  $SHOW_RESULTS=1;
  $JUMP_URL="http://www.schappenings.com/main.htm";

# These are the cosmetic settings in case you do not like my
# terrible taste in colors! The actual result page layout can
# be found near the bottom of the script.

  $TABLECOLOR="#FFFFFF";
  $HEADINGCOLOR="#000066";
  $HEADINGFONT="arial,helvetica";
  $BORDERCOLOR="#660000";
  $FONT="arial,helvetica";
  $FONTCOLOR="#000000";

# the script starts for real here....

  &decode_vars;
  &check_files;

  if ($ENV{'REQUEST_METHOD'} eq "POST" && -e $DATA_FILE && -w $DATA_FILE){
   if ($USE_COOKIES == 1){
     $COOKIEVAL=&get_cookie($SURVEY_NAME);
     if (  $COOKIEVAL > time){
      &already_voted;
      exit;
     }
     else{
      $cookie=&set_cookie($SURVEY_NAME,(time + ($HOURS * 3600)),$HOURS);
      print "$cookie\n";
     }
   }
   $MODE="VOTE";
   &set_colors;
   &process_file;
   &do_stats;
   if ($SHOW_RESULTS == 1){
     print "Content-type: text/html\n\n";
     $PAGEHEADER=&set_page_header;
     $PAGEFOOTER=&set_page_footer;
     print "$PAGEHEADER\n";
     &display_stats;
     print "$PAGEFOOTER\n";
   }
    else{
      print "Location: $JUMP_URL\n\n";
    }
   exit;
  }

  if ($ENV{'REQUEST_METHOD'} eq "GET" && -e $DATA_FILE){
   $MODE="VIEW";
   &set_colors;
   &process_file;
   &do_stats;
   $PAGEHEADER=&set_page_header;
   $PAGEFOOTER=&set_page_footer;
   print "Content-type: text/html\n\n";
   print "$PAGEHEADER\n";
   &display_stats;
   print "$PAGEFOOTER\n";
   exit;
  }


sub do_stats{
  $oldtag="NONE";
  @groups=();
  foreach $toshow (@list){
   @tags=split(/\|/,$toshow);
   if ($tags[0] ne $oldtag){
     $group=$tags[0];
     push(@groups,$group);
     $total{$group}=0;
     $oldtag = $tags[0];
   }
   $total{$group} = $total{$group} + $questions{$toshow};
  }
}

sub display_stats{
  $oldgroup="NONE";
  $itemcount=0;
  foreach $toshow (@list){
   @tags=split(/\|/,$toshow);
   if ($tags[0] ne $oldgroup){
     if ($oldgroup ne "NONE"){
        $GROUPFOOTER=&set_footer($total{$group});
        print "$GROUPFOOTER\n";
     }
     $group=$tags[0];
     $GROUPHEAD=&set_group_header($title{$group});
     print "$GROUPHEAD\n";
     $oldgroup=$group;
     $itemcount=0;
   }
   if ($total{$group} > 0){
     $pct=int((($questions{$toshow} / $total{$group}  * 100)+.5)) ;
   }
    else{
      $pct=0;
    }
   @qi=split(/\|/,$toshow);
   $giffile=@colors[$itemcount];
   $RESPONSELINE=&set_question($qi[1],$questions{$toshow},$pct, $giffile);
   print "$RESPONSELINE\n";
   $itemcount = $itemcount + 1;
  }
  $GROUPFOOTER=&set_footer($total{$group});
  print "$GROUPFOOTER\n";
}

sub process_file {
  &get_the_lock;
  if ($USE_LOGGING == 1 && $MODE eq "VOTE"){
    $SYSTIME=&sys_date;
    $LOG_LINE="$ENV{'REMOTE_ADDR'}\t$SYSTIME\t";
    open(LO,">>$LOG_FILE");
  }
  open(IX,"<$DATA_FILE");
  while ($line=<IX>){
    @loga=();
    chop $line;
    @parts=split(/:/,$line);
    $q=$parts[0];
    $n=$parts[1];
    $t=$parts[2];
    @tags=split(/\|/,$line);
    $ti=$tags[0];
    $title{$ti} = $t;
    $titles{$q} = $t;
    if ($fields{$ti} eq $q){ 
     $questions{$q} = $n + 1; 
     @loga=split(/\|/,$q);
     if ($USE_LOGGING == 1 && $MODE eq "VOTE"){$LOG_LINE .= "$loga[1]\t";}
    }
      else{ $questions{$q} = $n; }
    push(@list,$q);
  }
  close(IX);
  if ($MODE eq "VOTE"){
    open(IY,">$DATA_FILE");
    foreach $toshow (@list){
      print IY "$toshow:$questions{$toshow}:$titles{$toshow}:\n";
    }
    close(IY);
  }
  if ($USE_LOGGING == 1 && $MODE eq "VOTE"){
    if ($fields{'email'} eq ""){$fields{'email'}="no-email";}
    if ($fields{'comments'} eq ""){$fields{'comments'}="no-comment";}
    $LOG_LINE .= "$fields{'email'}\t$fields{'comments'}";
    print LO "$LOG_LINE\n";
    close(LO);
  }
  &drop_the_lock;
}

sub set_colors{
#this allows for up to 22 responses per question. if you have more, just 
#continue duplicating the middle two lines of the array below...

  @colors=("blue.gif","red.gif","green.gif","yellow.gif","cherry.gif",
           "navy.gif","pink.gif","black.gif","teal.gif","purple.gif","sky.gif",
           "blue.gif","red.gif","green.gif","yellow.gif","cherry.gif",
           "navy.gif","pink.gif","black.gif","teal.gif","purple.gif","sky.gif",
           "blue.gif","red.gif","green.gif","yellow.gif","cherry.gif",
           "navy.gif","pink.gif","black.gif","teal.gif","purple.gif","sky.gif",
           "blue.gif","red.gif","green.gif","yellow.gif","cherry.gif",
           "navy.gif","pink.gif","black.gif","teal.gif","purple.gif","sky.gif");
}

sub decode_vars
 {
 $i=0;
  if ( $ENV{'REQUEST_METHOD'} eq "GET")
   {
     $temp=$ENV{'QUERY_STRING'};
   }
   else
    {
      read(STDIN,$temp,$ENV{'CONTENT_LENGTH'});
    }
  @pairs=split(/&/,$temp);
  foreach $item(@pairs)
   {
    ($key,$content)=split(/=/,$item,2);
    $content=~tr/+/ /;
    $content=~s/%(..)/pack("c",hex($1))/ge;
    $content=~s/\012//gs;
    $content=~s/\015/ /gs;
    $fields{$key}=$content;
   }
  if ($fields{'survey_name'}=~/^([-\@\w.]+)$/){
    $SURVEY_NAME=$fields{'survey_name'};
  }
  else {exit;}
  $fields{'comments'}=~s/\t/ /g;
  $fields{'email'}=&valid_address($fields{'email'});
}

sub valid_address
 {
 my ($testmail) = @_;
  if ($testmail =~/ /)
   { return ""; }
  if ($testmail =~ /(@.*@)|(\.\.)|(@\.)|(\.@)|(^\.)/ ||
  $testmail !~ /^.+\@(\[?)[a-zA-Z0-9\-\.]+\.([a-zA-Z]{2,3}|[0-9]{1,3})(\]?)$/)
   { return ""; }
   else { return $testmail; }
}

sub get_the_lock
{
  if ($MODE ne "VOTE"){return;}
  $lockfile="$DATA_PATH/$SURVEY_NAME\.lkk";
  local ($endtime);
  $endtime = 40;
  $endtime = time + $endtime;
  while (-e $lockfile && time < $endtime)
   {
    # Do Nothing
   }
   open(LOCK_FILE, ">$lockfile");
}

sub drop_the_lock
{
  if ($MODE ne "VOTE"){return;}
  $lockfile="$DATA_PATH/$SURVEY_NAME\.lkk";
  close(LOCK_FILE);
  unlink($lockfile);
}

sub already_voted{
 print "Content-type: text/html\n\n";
 print<<__END_ALREADY_VOTED__;
 <h2 align=center>You Already Voted!</h2>


__END_ALREADY_VOTED__
}


#
# This routine takes (name,value,hours,path,domain) as arguments
# to set a cookie.
#
# 0 hours means a current browser session cookie life
#
sub set_cookie() {

  my ($name,$value,$expires) = @_;
  $name=&cookie_scrub($name);
  $value=&cookie_scrub($value);

  $expires=$expires * 3600;
  $expires=int($expires);

  my $expire_at=&cookie_date($expires);
  my $namevalue="$name=$value";

  my $COOKIE="";

  if ($expires != 0) {
     $COOKIE= "Set-Cookie: $namevalue; path=$path; expires=$expire_at; ";
  }
   else {
     $COOKIE= "Set-Cookie: $namevalue; ";   #current session cookie if 0
   }
  return $COOKIE;
}

#
# This routine removes cookie of (name) by setting the expiration
# to a date/time GMT of (now - 24hours)
#
sub remove_cookie() {

  my ($name) = @_;

  $name=&cookie_scrub($name);
  my $value="";
  my $cookie="";
  my $expires=&cookie_date(-86400);
  my $namevalue="$name=$value";

  my $COOKIE= "Set-Cookie: $namevalue; expires=$expires; ";

  return $COOKIE;
}


#
# given a cookie name, this routine returns the value component
# of the name=value pair
# a returned value of 0 means no cookie
sub get_cookie() {

  my ($name) = @_;

  $name=&cookie_scrub($name);
  my $temp=$ENV{'HTTP_COOKIE'};
  @pairs=split(/\; /,$temp);
  foreach my $sets (@pairs) {
    my ($key,$value)=split(/=/,$sets);
    $clist{$key} = $value;
  }
  if ($clist{$name} eq "") {$clist{$name}="0";}
  my $retval=$clist{$name};

  return $retval;
}

#
# this routine accepts the number of seconds to add to the server
# time to calculate the expiration string for the cookie. Cookie
# time is ALWAYS GMT!
#
sub cookie_date() {

  my ($seconds) = @_;

  my %mn = ('Jan','01', 'Feb','02', 'Mar','03', 'Apr','04',
            'May','05', 'Jun','06', 'Jul','07', 'Aug','08',
            'Sep','09', 'Oct','10', 'Nov','11', 'Dec','12' );
  my $sydate=gmtime(time+$seconds);
  my ($day, $month, $num, $time, $year) = split(/\s+/,$sydate);
  my    $zl=length($num);
  if ($zl == 1) { 
    $num = "0$num";
  }
  my $retdate="$day $num-$month-$year $time GMT";
  return $retdate;
}


#
# don't allow = or ; as valid elements of name or data
#
sub cookie_scrub() {
  my($retval) = @_;

  $retval=~s/\;//;
  $retval=~s/\=//;
  return $retval;
}

sub sys_date{
 my %mn = ('Jan','01', 'Feb','02', 'Mar','03', 'Apr','04',
        'May','05', 'Jun','06', 'Jul','07', 'Aug','08',
        'Sep','09', 'Oct','10', 'Nov','11', 'Dec','12' );
 my $sydate=localtime(time);
 my ($day, $month, $num, $time, $year) = split(/\s+/,$sydate);
 my $zl=length($num);
    if ($zl == 1) { $num = "0$num";}
 my $retval="$year\-$mn{$month}\-$num\t$time";
 return $retval;
}

sub check_files{
  $DATA_FILE="$DATA_PATH/$SURVEY_NAME\.srv";
  $LOG_FILE="$DATA_PATH/$SURVEY_NAME\.log";
  if ( !-e $DATA_FILE){
   print "Content-type: text/html\n\n Data File is Missing!\n";
   exit;
  }
  if ( !-w $DATA_FILE){
   print "Content-type: text/html\n\n Data File Cannot be Written to!\n";
   exit;
  }
  if ( !-e "$LOG_FILE" && $USE_LOGGING == 1){
   open(OP,">>$LOG_FILE");
   close(OP);
  }
  if ( !-w "$DATA_PATH/$SURVEY_NAME\.log" && $USE_LOGGING == 1){
   print "Content-type: text/html\n\n Log File Cannot be Written to!\n";
   exit;
  }
}

######################## COSMETIC SECTION ##########################
#
# The following subroutines contain the HTML text (and some logic
# so be careful editing!) that is presented when viewing the survey
# results.
#

sub set_page_header{
 my $PAGEHEAD=<<__END_PAGE_HEAD__;
 
 <BODY BGCOLOR="#FFFFFF">
 <CENTER>
<img border="0" src="http://www.schappenings.com/images3/sch_mainlogo_whitebg.jpg" width="350" height="133">
 <TABLE BORDER=0 BGCOLOR="$BORDERCOLOR" WIDTH=576>
  <TR>
  <TD ALIGN=CENTER>
 <TABLE BORDER=0 BGCOLOR="$TABLECOLOR" WIDTH=640>
  <TR>
  <TD COLSPAN=4>
  <CENTER>
  <FONT FACE="$HEADINGFONT" COLOR="$HEADINGCOLOR">
   <FONT SIZE=5><B>Pick the Next Update</B></FONT>
  <BR>
  
  <CENTER>
  <P>

__END_PAGE_HEAD__
 return $PAGEHEAD;
}

sub set_group_header{
 my ($GROUP_HEADING)=@_;
 my $GROUP_HEADER=<<__END_GROUP_HEADER__;

 <TR>
 <TD COLSPAN=4 ALIGN=CENTER>
  <FONT FACE="$HEADINGFONT" COLOR="$HEADINGCOLOR"><B>$GROUP_HEADING</B></FONT>
 </TD>
 </TR> 
 <TR>
  <TD WIDTH=300><FONT FACE="$FONT" COLOR="Red"><b><U>Response</U></B></TD>
  <TD WIDTH=30 ALIGN=RIGHT><FONT FACE="$FONT" COLOR="Red"><b><U>Number</U></B></TD>
  <TD WIDTH=30 ALIGN=RIGHT><FONT FACE="$FONT" COLOR="Red"><B><U>Percent</U></B></TD>
  <TD WIDTH=200><FONT FACE="$FONT" COLOR="Red"><B><U>Graph</U></B></TD>
 </TR>

__END_GROUP_HEADER__
return $GROUP_HEADER;
}

sub set_question{
 my ($respitem,$count,$pct,$giffile) = @_;
 my $factor = $pct * 2.50;
 my $SCALE=int($factor);
 my $RESPONSE=<<__END_RESPONSE_LINE__;

<TR>
  <TD VALIGN=TOP><FONT FACE="$FONT" COLOR="$FONTCOLOR">$respitem</FONT></TD>
  <TD VALIGN=TOP ALIGN=RIGHT><FONT FACE="$FONT" COLOR="$FONTCOLOR">$count</FONT></TD>
  <TD VALIGN=TOP ALIGN=RIGHT><FONT FACE="$FONT" COLOR="$FONTCOLOR">$pct\%</FONT></TD>
  <TD><IMG SRC="http://$DOMAIN/$GRAPHICSDIR/$giffile" HEIGHT=5 WIDTH=$SCALE BORDER=0></TD>
</TR>

__END_RESPONSE_LINE__
 return $RESPONSE;
}

sub set_footer{
 my ($tot) = @_;
 my $FOOTGROUP=<<__END_GROUP_FOOTER__;

 <TR>
 <TD COLSPAN=4 ALIGN=CENTER><FONT FACE="$FONT" COLOR="$FONTCOLOR">Total Number of Responses: $tot<P></FONT></TD>
 </TR>

__END_GROUP_FOOTER__
return $FOOTGROUP;
}

sub set_page_footer{
my $PAGEFOOT=<<__END_PAGE_FOOT__;
 </TD>
 </TR>
 <TR>
 <TD COLSPAN=4 ALIGN=CENTER>
  <FONT FACE="$FONT" COLOR="$FONTCOLOR">
  <A HREF="$JUMP_URL"><B>Continue</B></a>
  </FONT><p>
<font face="Arial" size="3"><center>IP addresses are logged for each vote while using this survey.<br>
Please do not vote multiple times.  One vote per 5 hour period.<b>
<br><font color="Red">All illegal votes will be thrown out!!!</b></center></font>
 </TD>
 </TR>
</TABLE>
 </TD>
 </TR>
</TABLE><p><p><p><p><p><p><p><p>
 <FONT SIZE=2>
 Another FREE Script from <A HREF="http://bignosebird.com/">BigNoseBird.Com</A>
</CENTER>
__END_PAGE_FOOT__
 return $PAGEFOOT;
}

#--------DISCLAIMER-AND-COPYRIGHT-INFORMATION---------------------------#
# ANY SOFTWARE PROVIDED BY BIGNOSEBIRD.COM, INC. IS ``AS IS'' AND ANY 
# EXPRESSED OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 
# PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL BIGNOSEBIRD.COM, INC. OR 
# ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 
# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 
# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE 
# USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 
# THIS SCRIPT IS PROVIDED WITHOUT SUPPORT 
#
# THIS SCRIPT IS FREEWARE AND CAN BE USED FOR BOTH COMMERCIAL AND 
# NON-COMMERCIAL USE. REPUBLICATION OF THE SCRIPT REQUIRES OUR PERMISSION.
# webmaster\@bignosebird.com
#-----------------------------------------------------------------------#