='.$cookie_date.';'; print ' path=/;'; print ' domain='.$cookie_domain.';\n'; } print "\n\n"; # Write the html page print $P; close(STDOUT); exit true; # ------------------------------------ # ---- Show A Perl Script Message ---- # ------------------------------------ sub showerror { print "Content-type: text/html\n\n"; print ""; print ""; print " $studyname "; print ""; print ""; print ""; print "StatPac Survey Processor

"; print "
"; print ""; print "$_[0]\n\n"; print ""; print ""; print ""; close(STDOUT); exit 0; } # ------------------------------- # --------- Read Cookie --------- # ------------------------------- sub read_cookie { $cookie_value = ''; if ($ENV{'HTTP_COOKIE'} ne '') { $cookie_value = $ENV{'HTTP_COOKIE'}; $Position = index($cookie_value, $cookie_name."\="); if ($Position != -1) { $cookie_value = substr($cookie_value, $Position + length($cookie_name) + 1); $Position = index($cookie_value, "\;"); $cookie_value = substr($cookie_value, 0, $Position); } # Decode cookie from hex to ASCII $cookie_value =~ tr/+/ /; $cookie_value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg; # Convert cookie values from: ^^ to = and :: to & $cookie_value =~ s/\^\^/=/g; $cookie_value =~ s/\:\:/&/g; #Split the cookie name=value&name=value into pairs @namval = sort(split(/&/,$cookie_value)); foreach (@namval) { tr/+/ /; s/=/ = /; s/%(..)/pack("C",hex($1))/ge; ($cnam, $cval) = split(/ = /,$_,2); $cookie{$cnam} = $cval; } } } # -------------------------------------------------------------------------------------- # ---- Prepare a cookie with respondent_ID, highest_page, and all the retain values ---- # -------------------------------------------------------------------------------------- sub prepare_cookie { # Get domain with a leading period as in .statpac.com $cookie_domain = $ENV {'SERVER_NAME'}; $cookie_domain =~ s/^www//i; if ($cookie_domain == "") { $url = $ENV {'HTTP_REFERER'}; $url =~ s/^http:\/\///i; $url =~ s/^https:\/\///i; $url =~ s/^www//i; $slash = index($url, "\/"); $cookie_domain = substr($url, 0, $slash); } # Format for cookie_date is: Wdy, DD-Mon-YYYY HH:MM:SS GMT @days = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat'); @months = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec'); ($sec,$min,$hour,$mday,$mon,$year,$wday) = (localtime(time))[0,1,2,3,4,5,6]; $time = sprintf("%02d:%02d:%02d",$hour,$min,$sec); if ($mday < 10) {$mday = "0".$mday;} $year += 1900 + 2; #Sets cookie expiration to 2 years $cookie_date = "$days[$wday], $mday-$months[$mon]-$year $time GMT"; #cookie uses "^^ as =" and ":: as &" $cookie_value = 'Respondent_ID^^'.$respondentID; $cookie_value .= '::'.'highestpage^^'.$highestpage; foreach $field (@Field_Order) { $lookfor = "/".$field."/"; if ($retain =~ m/$lookfor/i) { $cookie_value .= '::'.$field.'^^'.$dat{$field}; } } # Encode characters that can cause problems with cookie values $cookie_value =~ s/([^A-Za-z0-9])/sprintf("%%%02X", ord($1))/seg; $cookie_value =~ tr/ /+/; } # ------------------------------- # ---- Process the html form ---- # ------------------------------- sub process_form { # Define the configuration array for special fields # These fields will not be written to the response file %Config = ('recipient','', 'method','', 'directory','', 'studyname','', 'nexturl','', 'currentpage','', 'cache','', 'thankyoupage','', 'retain','', 'cookiecontrol','', 'button','', 'highestpage','', 'FileExt','', 'Respondent_ID','', 'basename',''); @pairs = split(/&/, $buffer); # Do for each name-value pair foreach $pair (@pairs) { # Split up the pair local($name, $value) = split(/=/, $pair); # Decode the form encoding $name =~ tr/+/ /; $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg; $value =~ tr/+/ /; $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg; # Erase any server side includes $value =~ s///g; # Erase any embedded carriage returns, tabs, line feed, & form feed characters $value =~ s/[\r\t\n\f]/ /g; # delete ^M's $value =~ s/\cM//g; # Erase any html tags $value =~ s//>/g; # Change double quote marks to single quote marks $value =~ s/\"/\'/g; # Put special field names in the %Config array & others in the %Form array # Save the order of the form fields in the @Field_Order array if (defined($Config{$name})) { $Config{$name} = $value; } else { if ($Form{$name} && $value) { $Form{$name} = "$Form{$name}, $value"; } elsif ($value || ($value eq '0')) { push(@Field_Order,$name); $Form{$name} = $value; } } } }