#Birds-Eye.Net survey.pl ScriptBack to Birds-Eye.Net Script Archive
#
#<![CDATA[#<PRE>
######################### DO NOT REMOVE THIS HEADER #################################
# #
# Birds-Eye Network Services, LLC #
# Birds-Eye.Net's Survey Generation Tool for Perl #
# survey-pl.htm #
# #
# This Perl streamlines the creation of online surveys by breaking down various #
# questions into simple subroutines and constructing any survey by building simple #
# lists of calls to the subroutines. #
# #
# By: Bruce Bahlmann #
# (C) Copyright, Birds-Eye Network Services, LLC, ALL RIGHTS RESERVED #
# #
# NOTICE: All use of the software (in whole or in part) is restricted. Any sale, #
# marketing, distribution, or transfer of software copies, associated data, source #
# code, information (including manuals), configuration files, or licenses are #
# restricted. Internal use of this software requires a license and/or express #
# written permission from Birds-Eye Network Services, LLC. Any other use of this #
# software is restricted. This software is not sold as part of an enterprise #
# license and thus is restricted as such. #
# #
# To purchase access rights to this software contact: #
# Birds-Eye.Net, LLC #
# info[_at_]birds-eye.net #
# OR go to www.birds-eye.net/consulting to obtain a license #
# #
######################### DO NOT REMOVE THIS HEADER #################################
#!/usr/local/bin/perl
#
############################# About The Script #########################################
#
# Script Name: survey.pl
# Creator : Bruce F. Bahlmann
# Date : 10/20/98
# Description: Survey building tool
#
#
#
############################# Operational Requirements/Instructions ####################
#
# Intended Hardware Platform: Any
# Intended Software Platform: Any
#
# REQUIRED RESOURCES:
#
# Modules: None
# APIs: None
# Datastores: None
# Applications: Web server
# Other:
#
# Intstallation Instructions:
#
#
# HTMLized Server Name (optional):
$server_name = "";
$small_server_name = "";
############################# Release Schedule of Changes ##############################
#
# RELEASES:
#
# Ver: Date: Developer: Description of changes:
# 00.xx 00/00/19xx
# 00.01 10/15/1998 bahlmann Initial Release
#
$Version = "00.01"; # Keep current with that above
########################################################################################
# Configuration variables -- application specific
########################################################################################
$header_html = ""; # Path to User's header
$footer_html = ""; # Path to User's footer
$bgcolor = "#FFFFFF"; # Background color of HTML
$txtcolor = "#000000"; # Text color of HTML
$ercolor = "#FF0000"; # Text color of errors
$reg_home = "/web/userdb/quake"; # Path for registry data (protect)
$exec_reg = "/cgi-bin/survey.pl"; # Path to survey.pl script
$datafile = "/web/userdb/survey/self-install.dat"; # Location of flat file response data
$bookmark = "MediaOne Self-Install Survey"; # Bookmark for On-Line (don't change)
$forwardURL = "http://www.mn.mediaone.net"; # Forwarding URL push
$webmaster = "self-install\@mediaone.com"; # Support Contact (escape \ any @)
$successful = "1"; # Successful operation value
$unsuccessful = "-1"; # Unsuccessful operation value
########################################################################################
# Global variables used in this CGI script
########################################################################################
$no_cache = 0; # HTTP cache switch 1=no-caching, 0=activate BACK browser button
$test_flag = 0; # Diagonistic flag: 1=test, 0=normal operation
$no_redirect = 0; # HTTP redirect switch 1=redirect, 0=no-redirect (stay on page)
&Parse_Form_Data (*data_received);
&Process_Options(%data_received);
########################################################################################
# Process_Options -- Determine Submit options and process accordingly
#
# Parameters -
# data - A hash of the key value pairs passed by a CGI form
#
# Returns - None
########################################################################################
sub Process_Options {
local (%data) = @_;
&Show_Survey(%data) if ($data{'submit'} eq "");
&Check_Survey(%data) if ($data{'submit'} eq "Submit Responses");
} # end Process_Options
########################################################################################
# Thank_You -- Response to a completed survey
#
# Parameters -
# data - HTML form data
#
# Returns - None -- exits
########################################################################################
sub Thank_You {
local (*data) = @_;
$no_redirect = 1; # HTTP redirect switch 1=redirect, 0=no-redirect (stay on page)
$page_name = "MediaOne Self-Install";
@html = &Load_Header ($bookmark, "$server_name $page_name", $header_html, %data);
$lcv = @html;
$html[$lcv++] = "<FONT COLOR=#0000FF><H2>Thank You!</H2></FONT><P>";
$html[$lcv++] = "MediaOne would like to thank you for your help in providing feedback";
$html[$lcv++] = "that will help MediaOne offer Self Install to other customers.";
$html[$lcv++] = "<P>";
&Load_Footer ($footer_html, @html);
}
########################################################################################
# Show_Survey -- Displays survey
#
# Parameters -
# data - HTML form data
#
# Returns - None -- exits
########################################################################################
sub Show_Survey {
local (%data) = @_;
my ($page_name);
local (@html, $lcv);
#$no_cache = 1; # HTTP cache switch 1=no-caching, 0=activate BACK browser button
$page_name = "MediaOne Self-Install Survey";
@html = &Load_Header ($bookmark, "$server_name $page_name", $header_html, %data);
$lcv = @html;
$html[$lcv++] = "We are very interested in your opinion and experience during the Self Installation of MediaOne Express. Please take a few minutes to complete this questionnaire so we can understand how we can improve the Self Installation offering.<BR><BR>";
$html[$lcv++] = "<TABLE BORDER=0>";
$html[$lcv++] = "<TR><TD WIDTH=50%></TD><TD WIDTH=5%></TD><TD WIDTH=0%></TD><TD WIDTH=45%></TD></TR>";
$html[$lcv++] = "<TR><TD><B><U>Overall Satisfaction</U></B></TD></TR>";
$html[$lcv++] = "<TR><TD COLSPAN=4>1. Using a scale from 1-10 where 10 means <I>EXTREMELY SATISFIED</I> and 1 means <I>EXTREMELY DISSATISFIED</I>, how would you rate your satisfaction level with each of the following:(Please mark one answer for each item listed).<BR><BR></TR>";
&Radio_Heading ('Extremely Satisfied', 'Extremely Dissatisfied', *lcv, *html);
&Radio_Question ('siexp', '<U>Overall Self Installation Experience</U>', '10', 'J', *lcv, *html, *data);
&Radio_Question ('cinst', 'Cable Installation', '10', 'J', *lcv, *html, *data);
&Radio_Question ('pcinst', 'PC Installation', '10', 'J', *lcv, *html, *data);
&Radio_Question ('bcminst', 'Browser/Cable Modem Installation', '10', 'L', *lcv, *html, *data);
&Radio_Question ('sinstkit', '<U>Overall Self Installation Kit</U>', '10', 'J', *lcv, *html, *data);
&Radio_Question ('instequip', 'Installation Equipment', '10', 'J', *lcv, *html, *data);
&Radio_Question ('cinstdoc', 'Cable Installation Documentation', '10', 'J', *lcv, *html, *data);
&Radio_Question ('pcinstdoc', 'PC Installation Documentation', '10', 'J', *lcv, *html, *data);
&Radio_Question ('bcminstdoc', 'Browser/Cable Modem Installation Documentation', '10', 'L', *lcv, *html, *data);
&Radio_Question ('moinstsup', '<U>MediaOne Installation Support</U>', '10', 'J', *lcv, *html, *data);
&Radio_Question ('scheduling', 'Scheduling to receive Self Install Kit', '10', 'J', *lcv, *html, *data);
&Radio_Question ('techsupinst', 'Technical Support during Installation', '10', 'J', *lcv, *html, *data);
&Radio_Question ('schbegmosvc', 'Scheduling to begin MediaOne Internet Service', '10', 'L', *lcv, *html, *data);
$html[$lcv++] = "<TR><TD><B><U>Installation</U></B></TD></TR>";
&DropDown_Question ('insttime', '2. How Long did your installation take to complete ?',
'J', *lcv, *html, *data
, 'Less than one hour|One to two hours|Two to three hours|Three to four hours|More than four hours'
);
&TextBox_Question ('improvinst', '3. What, if anything, would you do to improve the Self Installation process ? Please be as specific as possible.'
, 'L', *lcv, *html, *data);
$html[$lcv++] = "<TR><TD><B><U>Self Install Kit</U></B></TD></TR>";
&TextBox_Question ('instkit', '4. What, if anything, would you do to improve the Self Installation kit ? Please be as specific as possible.'
, 'L', *lcv, *html, *data);
$html[$lcv++] = "<TR><TD><B><U>Support</U></B></TD></TR>";
&DropDown_Question ('techprob', '5. Did you ever experience any technical problems during the installation of MediaOne Express ?',
'J', *lcv, *html, *data
, 'Yes|No');
&TextBox_Question ('listprob', '6. Please describe any problems your experienced during the installation of MediaOne Express. Please be as specific as possible.'
, 'J', *lcv, *html, *data);
&DropDown_Question ('techsupport', '7. Was it necessary for you to call MediaOne Technical support to fix the problem(s) ?',
'L', *lcv, *html, *data
, 'Yes|No|N/A');
$html[$lcv++] = "<TR><TD><B><U>Value of Self Install</U></B></TD></TR>";
&TextBox_Question ('instreas', '8. What was the main reason you were interested in a Self Installation of MediaOne Express ? Please be as specific as possible.'
, 'J', *lcv, *html, *data);
&DropDown_Question ('howlik', '9. How likely would you be to complete a Self Installation of MediaOne Express if the Installation kit was priced the same as a MediaOne installation ?',
'L', *lcv, *html, *data
, 'Extremely likely|Very likely|Somewhat likely|Not very likely|Not at all likely');
&Weighted_Question ('weighsi', '10. Below are listed some possible reasons why you may have decided to complete a Self Installation of MediaOne Express. Please look at the list and divide 10 points among the following reasons according to how important each reason was in your decision to complete a Self Installation of MediaOne Express. You may allocate all 10 points to one reason or divide them among many reasons. You do not have to allocate points to every reason listed. <I>Please make sure your points total 10</I>.',
'L', *lcv, *html, *data
, 'Was able to complete the installation at my convenience|Allowed me to activate the MediaOne Express service faster than if I had to schedule an installation|Because I saved money on the installation|Because I thought it would be fun and challenging|Because I was interested in participating in a special test group|I prefer to be the only one who configures my personal computer|Other');
$html[$lcv++] = "<TR><TD><B><U>User Skill Level</U></B></TD></TR>";
$html[$lcv++] = "<TR><TD COLSPAN=4>11. Using a scale from 1-10 where 10 means <I>EXTREMELY COMFORTABLE</I> and 1 means <I>EXTREMELY UNCOMFORTABLE</I>, how would you rate your skill level with each of the following: (Please mark one answer for each item listed).<BR><BR></TD></TR>";
&Radio_Heading ('Extremely Comfortable', 'Extremely Uncomfortable', *lcv, *html);
&Radio_Question ('openpc', 'Opening a PC enclosure', '10', 'J', *lcv, *html, *data);
&Radio_Question ('instpcnic', 'Installing computer expansion card', '10', 'J', *lcv, *html, *data);
&Radio_Question ('troubpc', 'Toubleshooting PC problems', '10', 'J', *lcv, *html, *data);
&Radio_Question ('confsftw', 'Installing/configuring PC software', '10', 'J', *lcv, *html, *data);
&Radio_Question ('wiring', 'Wiring a cable/telephone outlet', '10', 'J', *lcv, *html, *data);
&Radio_Question ('hndtools', 'Using hand/power tools', '10', 'J', *lcv, *html, *data);
&Radio_Question ('hmimprov', 'General home improvement projects', '10', 'L', *lcv, *html, *data);
$html[$lcv++] = "<TR><TD><B><U>User Information</U></B></TD><TD></TD></TR>";
&DropDown_Question ('catv', '12. Does your household currently subscribe to cable television ?',
'J', *lcv, *html, *data
, 'Yes|No|Don\'t know');
&DropDown_Question ('numpcs', '13. How may personal computers do you have in your household ?',
'J', *lcv, *html, *data
, '0|1|2|3+|Don\'t know');
&DropDown_Question ('typepc', '14. What type of computer processor do you have in your newest home computer ?',
'J', *lcv, *html, *data
, '386 or below|486|Pentium|Pentium II|68030|68040|PPC|G3|Other|Don\'t know');
&DropDown_Question ('oltime', '15. Each time you access the Internet, on average, how much time do you spend online ?',
'J', *lcv, *html, *data
, 'Less than 10 minutes|10 to less than 30 minutes|30 to less than 1 hour|1 hour to less than 2 hours|2 hours to less than 3 hours|3 to 4 hours|More than 4 hours|Don\'t know|Refused');
&DropDown_Question ('ownrent', '16. Do you own or rent your home/apt ?',
'J', *lcv, *html, *data
, 'Own|Rent|Some other arrangement');
&DropDown_Question ('employ', '17. What is your employment status ?',
'J', *lcv, *html, *data
, 'Employed full time|Employed part time|Temporarily unemployed|Homemaker|Retired|Full time student|Other');
&TextBox_Question ('descocc', '18. Please describe your occupation ? Please be as specific as possible.'
, 'J', *lcv, *html, *data);
&DropDown_Question ('gender', '19. What is your gender ?',
'J', *lcv, *html, *data
, 'Male|Female');
&DropDown_Question ('agegrp', '20. Which of the following categories does your age fall ?',
'J', *lcv, *html, *data
, '18-24|25-34|35-44|45-54|55-64|65 and over|Don\'t know|Refused');
&DropDown_Question ('school', '21. Please tell me the highest level of education you have completed ?',
'J', *lcv, *html, *data
, 'Did not graduate high school|High school degree|Some college|Trade/technical school|College degree|Some graduate school|Graduate degree|Other|Don\'t know|Refused');
&DropDown_Question ('m1emp', '22. Are you a MediaOne employee ?',
'L', *lcv, *html, *data
, 'Yes|No');
$html[$lcv++] = "<TR><TD><B><U>Contact Information</U></B></TD><TD></TD></TR>";
$html[$lcv++] = "<TR><TD>First Name:</TD><TD COLSPAN=2><INPUT TYPE=\"text\" NAME=\"fname\" SIZE=12 VALUE=\"$data{'fname'}\"></TD></TR>";
$html[$lcv++] = "<TR><TD>Last Name:</TD><TD COLSPAN=2><INPUT TYPE=text NAME=\"lname\" SIZE=15 VALUE=\"$data{'lname'}\"></TD></TR>";
$html[$lcv++] = "<TR><TD>Day Phone Number:</TD><TD><INPUT TYPE=text NAME=\"phone\" SIZE=18 VALUE=\"$data{'phone'}\"></TD></TR>";
$html[$lcv++] = "<TR><TD>Email Address:</TD><TD><INPUT TYPE=text NAME=\"email\" SIZE=25 VALUE=\"$data{'email'}\"></TD></TR>";
$html[$lcv++] = "<TR><TD>City:</TD><TD><INPUT TYPE=text NAME=\"city\" SIZE=25 VALUE=\"$data{'city'}\"></TD></TR>";
&DropDown_Question ('state', 'State:',
'J', *lcv, *html, *data
, 'FL|MI|MN');
&DropDown_Question ('followup', 'May we contact you for a follow-up interview ?',
'L', *lcv, *html, *data
, 'Yes|No');
$html[$lcv++] = "</TABLE>";
$html[$lcv++] = "<P><INPUT TYPE=\"submit\" NAME=\"submit\" VALUE=\"Submit Responses\">";
&Load_Footer ($footer_html, @html);
}
########################################################################################
# Check_Survey -- Check survey fields for completeness
#
# Parameters -
# data - HTML form data
#
# Returns - None
########################################################################################
sub Check_Survey {
local (%data) = @_;
#### Remove any "|" (which is used internally as a delimiter) from text boxes
$data{'improvinst'} =~ s/\|//g;
$data{'improvinst'} =~ s/\s/\ /sxg;
$data{'instkit'} =~ s/\|//g;
$data{'instkit'} =~ s/\s/\ /sxg;
$data{'listprob'} =~ s/\|//g;
$data{'listprob'} =~ s/\s/\ /sxg;
$data{'instreas'} =~ s/\|//g;
$data{'instreas'} =~ s/\s/\ /sxg;
$data{'descocc'} =~ s/\|//g;
$data{'descocc'} =~ s/\s/\ /sxg;
$data{'returnerror'} = "";
if (($data{'siexp'} eq "")||($data{'cinst'} eq "")||($data{'pcinst'} eq "")||($data{'bcminst'} eq "")) {
$data{'returnerror'} .= "Item in <U>Overall Self Install Experience</U> section is not complete -- correct and resubmit<BR>";
} if (($data{'sinstkit'} eq "")||($data{'instequip'} eq "")||($data{'cinstdoc'} eq "")||
($data{'pcinstdoc'} eq "")||($data{'bcminstdoc'} eq "")) {
$data{'returnerror'} .= "Item in <U>Overall Self Installation Kit</U> section is not complete -- correct and resubmit<BR>";
} if (($data{'moinstsup'} eq "")||($data{'scheduling'} eq "")||($data{'techsupinst'} eq "")||
($data{'schbegmosvc'} eq "")) {
$data{'returnerror'} .= "Item in <U>MediaOne Installation Support</U> section is not complete -- correct and resubmit<BR>";
} if (($data{'insttime'} eq "")||(&Confirm_TextBox('improvinst', 'o', *data))) {
$data{'returnerror'} .= "Item in <U>Installation</U> section is not complete -- correct and resubmit<BR>";
} if (&Confirm_TextBox('instkit', 'o', *data)) {
$data{'returnerror'} .= "Item in <U>Self Install Kit</U> section is not complete -- correct and resubmit<BR>";
} if (($data{'techprob'} eq "")||(&Confirm_TextBox('listprob', 'o', *data))||($data{'techsupport'} eq "")) {
$data{'returnerror'} .= "Item in <U>Support</U> section is not complete -- correct and resubmit<BR>";
} if ((&Confirm_TextBox('instreas', 'o', *data))||($data{'howlik'} eq "")||(&Confirm_Weight('weighsi', '10', *data))) {
$data{'returnerror'} .= "Item in <U>Value of Self Install</U> section is not complete -- correct and resubmit<BR>";
} if (($data{'openpc'} eq "")||($data{'instpcnic'} eq "")||($data{'troubpc'} eq "")||
($data{'confsftw'} eq "")||($data{'wiring'} eq "")||($data{'hndtools'} eq "")||($data{'hmimprov'} eq "")) {
$data{'returnerror'} .= "Item in <U>User Skill Level</U> section is not complete -- correct and resubmit<BR>";
} if (($data{'catv'} eq "")||($data{'numpcs'} eq "")||($data{'typepc'} eq "")||($data{'oltime'} eq "")||
($data{'ownrent'} eq "")||($data{'employ'} eq "")||(&Confirm_TextBox('descocc', 'o', *data))||
($data{'gender'} eq "")||($data{'agegrp'} eq "")||($data{'school'} eq "")||($data{'m1emp'} eq "")) {
$data{'returnerror'} .= "Item in <U>User Information</U> section is not complete -- correct and resubmit<BR>";
} if (($data{'fname'} eq "")||($data{'lname'} eq "")||($data{'phone'} eq "")||($data{'email'} eq "")||
($data{'city'} eq "")||($data{'state'} eq "")||($data{'followup'} eq "")) {
$data{'returnerror'} .= "Item in <U>Contact Information</U> section is not complete -- correct and resubmit<BR>";
}
if ($data{'returnerror'} ne "") {
&Show_Survey(%data);
}
&Save_Data (*data)
&Thank_You (*data);
}
########################################################################################
# Save_Data -- Append questionnaire data file with response
#
# Parameters -
# data - Passed HTML form data
#
# Returns - None
########################################################################################
sub Save_Data {
local (*data) = @_;
my ($date, $message);
$date = localtime(time);
open (FILE, ">>$datafile");
print FILE "$date|$data{'siexp'}|$data{'cinst'}|$data{'pcinst'}|$data{'bcminst'}|$data{'sinstkit'}|$data{'instequip'}|$data{'cinstdoc'}|$data{'pcinstdoc'}|$data{'bcminstdoc'}|$data{'moinstsup'}|$data{'scheduling'}|$data{'techsupinst'}|$data{'schbegmosvc'}|$data{'insttime'}|$data{'improvinst'}|$data{'instkit'}|$data{'techprob'}|$data{'listprob'}|$data{'techsupport'}|$data{'instreas'}|$data{'howlik'}|$data{'weighsi1'}|$data{'weighsi2'}|$data{'weighsi3'}|$data{'weighsi4'}|$data{'weighsi5'}|$data{'weighsi6'}|$data{'weighsi7'}|$data{'weighsi8'}|$data{'openpc'}|$data{'instpcnic'}|$data{'troubpc'}|$data{'confsftw'}|$data{'wiring'}|$data{'hndtools'}|$data{'hmimprov'}|$data{'catv'}|$data{'numpcs'}|$data{'typepc'}|$data{'oltime'}|$data{'ownrent'}|$data{'employ'}|$data{'descocc'}|$data{'gender'}|$data{'agegrp'}|$data{'school'}|$data{'m1emp'}|$data{'fname'}|$data{'lname'}|$data{'phone'}|$data{'email'}|$data{'city'}|$data{'state'}|$data{'followup'}||||||\n";
close (FILE);
#### Send confirmation message:
$message = "Name: [$data{'fname'}] [$data{'lname'}]\n";
$message .= "Phone: [$data{'phone'}]\n";
$message .= "City: [$data{'city'}] State: [$data{'state'}]\n";
$message .= "Email: [$data{'email'}]\n\n";
$message .= "Follow-Up: [$data{'followup'}]\n\n";
$message .= "M1 Employee: [$data{'m1emp'}]\n";
&Send_Mail('self-install@mediaone.com', "Survey Complete: [$data{'fname'}][$data{'lname'}]", $message);
}
########################################################################################
# Confirm_Weight -- A function that confirms weighted question is complete
#
# Parameters -
# field - HTML form field base name
# sum - Maximum count confirming
# data - Passed HTML form data
#
# Returns - 1/TRUE if total != sum, 0/FALSE if total == sum
########################################################################################
sub Confirm_Weight {
local ($field, $sum, *data) = @_;
my ($total, $input_var);
$total = 0;
for ($x=1; $x<11; $x++) {
$input_var = $field . $x;
$total = $total + $data{$input_var};
}
if ($total == $sum) {
return ("0");
} else {
return ("1");
}
}
########################################################################################
# Weighted_Question -- Build HTML for weighted questions
#
# Parameters -
# field - HTML form field base name
# name - Name of question
# action - J for Join (grouping), L for Last (end of grouping)
# lcv - Array counter
# html - HTML array
# data - Passed HTML form data
# options - Options passed in delimited (|) form
#
# Returns - (values passed back)
########################################################################################
sub Weighted_Question {
local ($field, $name, $action, *lcv, *html, *data, $options) = @_;
my (@opt, $x, $input_var);
($opt[1], $opt[2], $opt[3], $opt[4], $opt[5], $opt[6], $opt[7], $opt[8], $opt[9], $opt[10]) = split (/\|/, $options);
$html[$lcv++] = "<TR><TD VALIGN=TOP COLSPAN=4>$name<BR><BR></TD></TR>";
for ($x=1; $x<(@opt+1); $x++) {
if ($opt[$x] eq "") {
last;
}
$input_var = $field . $x;
$html[$lcv] = "<TR><TD VALIGN=TOP ALIGN=RIGHT>";
$html[$lcv] .= "<INPUT TYPE=TEXT NAME=\"$input_var\" SIZE=2 MAXLENGTH=2 VALUE=\"$data{$input_var}\"></TD>";
$html[$lcv++] .= "<TD VALIGN=TOP ALIGN=LEFT COLSPAN=3>$opt[$x]</TD></TR>";
}
}
########################################################################################
# Confirm_TextBox -- A function that confirms that textbox is completed correctly
#
# Parameters -
# field - HTML form field name
# action - 'o' for optional, 'm' for manditory
# data - Passed HTML form data
#
# Returns - 1/TRUE if total != sum, 0/FALSE if total == sum
########################################################################################
sub Confirm_TextBox {
local ($field, $action, *data) = @_;
return ("0") if ($action eq 'o');
if ($data{$field} eq "") {
return ("1");
} else {
return ("0");
}
}
########################################################################################
# TextBox_Question -- Build HTML for TextBox questions
#
# Parameters -
# field - HTML form field name
# name - Name of question
# action - J for Join (grouping), L for Last (end of grouping)
# lcv - Array counter
# html - HTML array
# data - Passed HTML form data
#
# Returns - (values passed back)
########################################################################################
sub TextBox_Question {
local ($field, $name, $action, *lcv, *html, *data) = @_;
$html[$lcv] = "<TR><TD VALIGN=TOP>$name</TD>";
$html[$lcv] .= "<TD VALIGN=TOP COLSPAN=2><TEXTAREA NAME=\"$field\" ROWS=10 COLS=35 WRAP=VIRTUAL>$data{$field}</TEXTAREA>";
$html[$lcv] .= "<BR><BR>" if ($action eq "L");
$html[$lcv++] .= "</TD><TD></TD></TR>";
}
########################################################################################
# DropDown_Question -- Build HTML for dropdown questions
#
# Parameters -
# field - HTML form field name
# name - Name of question
# action - J for Join (grouping), L for Last (end of grouping)
# lcv - Array counter
# html - HTML array
# data - Passed HTML form data
# options - Options passed in delimited (|) form
#
# Returns - (values passed back)
########################################################################################
sub DropDown_Question {
local ($field, $name, $action, *lcv, *html, *data, $options) = @_;
my (@opt, $x);
($opt[1], $opt[2], $opt[3], $opt[4], $opt[5], $opt[6], $opt[7], $opt[8], $opt[9], $opt[10]) = split (/\|/, $options);
$html[$lcv] = "<TR><TD>$name</TD><TD COLSPAN=2>" if ($action eq "J");
$html[$lcv] = "<TR><TD>$name<BR><BR></TD><TD VALIGN=TOP COLSPAN=2>" if ($action eq "L");
$html[$lcv] .= "<SELECT NAME=\"$field\">";
$html[$lcv] .= "<OPTION VALUE=\"\">select one of the following</OPTION>";
for ($x=1; $x<(@opt+1); $x++) {
if ($opt[$x] eq "") {
last;
}
$html[$lcv] .= "<OPTION";
$html[$lcv] .= " SELECTED" if ($opt[$x] eq $data{$field});
$html[$lcv] .= ">";
$html[$lcv] .= "$opt[$x]</OPTION>";
}
$html[$lcv++] .= "</SELECT></TD><TD></TD></TR>";
}
########################################################################################
# Radio_Heading -- Build HTML heading radio questions
#
# Parameters -
# left - HTML form field name
# right - Name of question
# lcv - Array counter
# html - HTML array
#
# Returns - (values passed back)
########################################################################################
sub Radio_Heading {
local ($left, $right, *lcv, *html) = @_;
## Replace spaces with HTML carrage returns
$left =~ s/\ /<BR>/g;
$right =~ s/\ /<BR>/g;
$html[$lcv] = "<TR><TD></TD><TD VALIGN=TOP><FONT SIZE=-2 ALIGN=LEFT><I>$left</I></FONT></TD>";
$html[$lcv++] .= "<TD ALIGN=RIGHT><FONT SIZE=-2 ALIGN=RIGHT><I>$right</I></FONT></TD><TD></TD></TR>";
}
########################################################################################
# Radio_Question -- Build HTML for radio questions
#
# Parameters -
# field - HTML form field name
# name - Name of question
# numquest - How many questions (starting at 1)
# action - J for Join (grouping), L for Last (end of grouping)
# lcv - Array counter
# html - HTML array
# data - Passed HTML form data
#
# Returns - (values passed back)
########################################################################################
sub Radio_Question {
local ($field, $name, $numquest, $action, *lcv, *html, *data) = @_;
my ($x);
$html[$lcv] = "<TR><TD>$name:</TD><TD COLSPAN=2>" if ($action eq "J");
$html[$lcv] = "<TR><TD>$name:<BR><BR></TD><TD VALIGN=TOP COLSPAN=2>" if ($action eq "L");
for ($x=$numquest; $x>0; $x--) {
$html[$lcv] .= " $x<INPUT TYPE=radio NAME=\"$field\" VALUE=\"$x\"";
$html[$lcv] .= " CHECKED" if ($x eq $data{$field});
$html[$lcv] .= ">";
}
$html[$lcv++] .= "</TD></TR>";
}
########################################################################################
# Send_Mail -- Send email to a specific user
#
# Parameters -
# to - Users email address
# subject - Subject of email
# message - Email text that is to be sent
#
# Returns - (values passed back)
########################################################################################
sub Send_Mail {
my ($to, $subject, $message) = @_;
my ($body) = "";
## Create message text
$body = "\n";
$body .= "$message";
## Escape @ which is a restricted character
$to =~ s/\@/\\\@/;
open (SENDMAIL, "|/usr/bin/mailx -r \"$webmaster\" -s \"$subject\" $to");
print SENDMAIL $body;
close (SENDMAIL);
}
########################################################################################
# Load_Footer -- Loads Footer text from below or from an external file prints and exits
#
# Parameters -
# footer_file - Name of footer file to include (if any)
# html - Array of HTML text
#
# Returns - None -- exits
########################################################################################
sub Load_Footer {
my ($footer_file, @html) = @_;
my (@footer_text, $l, $lcv);
## Initialize lcv to last line of HTML array
$lcv = @html;
$html[$lcv++] = "<INPUT TYPE=\"hidden\" NAME=\"returnerror\" VALUE=\"Ok\">";
$html[$lcv++] = "<INPUT TYPE=\"hidden\" NAME=\"returninfo\" VALUE=\"Ok\">";
$html[$lcv++] = "</FORM>";
## Load default footer -- if footer text does not exist
if ((($footer_file eq "")||($footer_file == 0))||(!(-r $footer_file))) {
### todo -- grep for FORM and only include if previously in HTML text
$html[$lcv++] = "</BODY>";
$html[$lcv++] = "</HTML>";
} else {
open (F, "$footer_file");
@footer_text = <F>;
close (F);
for ($l=0; $l<@footer_text; $l++) {
chomp $footer_text[$l];
$html[$lcv++] = $footer_text[$l];
}
}
for ($l=0; $l<@html; $l++) {
print "$html[$l]\n";
}
#print @html;
exit (0);
}
########################################################################################
# Load_Header -- Loads header text from below or from an external file
#
# Parameters -
# title - Title of dynamically generated page
# header_file - Location of header file
#
# Returns - An array of header HTML text
########################################################################################
sub Load_Header {
my ($bookmark, $title, $header_file, %data) = @_;
my (@html, @header_text, $l, $lcv);
$lcv = 0;
$html[$lcv++] = "Content-type: text/html\n";
## Prevent user from using "BACK" key -- overwrite previous HTML page
$html[$lcv++] = "<META HTTP-EQUIV=\"Pragma\" CONTENT=\"no-cache\">\n" if $no_cache;
$html[$lcv++] = "<META HTTP-EQUIV=\"refresh\" CONTENT=\"9\; URL=$forwardURL\">\n" if $no_redirect;
## Load default header -- if header text does not exist
if ((($header_file eq "")||($header_file == 0))||(!(-r $header_file))) {
$html[$lcv++] = "<HTML>";
$html[$lcv++] = "<HEAD>";
$html[$lcv++] = "<TITLE>$bookmark</TITLE>";
$html[$lcv++] = "</HEAD>";
$html[$lcv++] = "<BODY BGCOLOR=$bgcolor TEXT=$txtcolor LINK=\"#00ff00\" VLINK=\"#ffffff\">";
$html[$lcv++] = "<FORM METHOD=POST ACTION=\"$exec_reg\">";
} else {
open (F, "$header_file");
@header_text = <F>;
close (F);
for ($l=0; $l<@header_text; $l++) {
chomp $header_text[$l];
$html[$lcv++] = $header_text[$l];
}
}
$html[$lcv++] = "<H1>$title</H1><BR>";
if (($data{'returnerror'} ne "Ok")&&($data{'returnerror'} ne "")) {
$html[$lcv++] = "<TABLE BORDER=0>";
$html[$lcv++] = "<TR><TD VALIGN=TOP><FONT COLOR=$ercolor><B>ERROR:</B></FONT></TD><TD>$data{'returnerror'}</TD></TR>";
$html[$lcv++] = "</TABLE><P>";
} elsif (($data{'returninfo'} ne "Ok")&&($data{'returninfo'} ne "")) {
$html[$lcv++] = "<FONT COLOR=FFFF00>$data{'returninfo'}</FONT><P>";
}
return (@html);
}
########################################################################################
# Parse_Form_Data -- Extract form data from CGI string
#
# Parameters -
# FORM_DATA - Initially blank (source is QUERY_STRING or CONTENT_LENGTH)
# depending on the REQUEST_METHOD
#
# Returns -
# FORM_DATA - A hash of form key value pairs
########################################################################################
sub Parse_Form_Data {
local (*FORM_DATA) = @_;
my ($request_method, $query_string, @key_value_pairs, $key_value, $key, $value);
$request_method = $ENV{'REQUEST_METHOD'};
if ($request_method eq "GET") {
$query_string = $ENV{'QUERY_STRING'};
} elsif ($request_method eq "POST") {
read (STDIN, $query_string, $ENV{'CONTENT_LENGTH'});
} else {
&Return_Error (500, "Server Error", "Server uses unsupported method");
} # end if
@key_value_pairs = split (/&/, $query_string);
foreach $key_value (@key_value_pairs) {
($key, $value) = split (/=/, $key_value);
$value =~ tr/+/ /;
$value =~ s/%([\dA-Fa-f][\dA-Fa-f])/pack ("C", hex ($1))/eg;
if (defined($FORM_DATA{$key})) {
$FORM_DATA{$key} = join ("\0", $FORM_DATA{$key}, $value);
} else {
$FORM_DATA{$key} = $value;
} # end if
} # end foreach
} # end of sub Parse_Form_Data
########################################################################################
# Return_Error -- sends back message when CGI fails
#
# Parameters -
# status -
# keyword -
# message -
#
# Returns - None
########################################################################################
sub Return_Error {
my ($status, $keyword, $message) = @_;
print "Content-type: text/html\n";
print "Status: $status Keyword: $keyword\n\n";
print <<End_of_Error;
<title>CGI Program - Unexpected Error</title>
<h1>$keyword</h1>
<hr>$message</hr>
Please contact $webmaster for more information.
End_of_Error
exit(1);
} # end of sub Return_Error
</BODY><HTML><BODY BGCOLOR=$bgcolor TEXT=$txtcolor LINK=\"#00ff00\" VLINK=\"#ffffff\">
]]></plaintext></body>