#!/usr/local/bin/perl -Tw # # $Source: /home/cur/djb1/develop/questionnaire/RCS/questionnaire.pl,v $ # # $Id: questionnaire.pl,v 1.15 1998/06/03 13:57:27 djb1 Exp $ # # Questionnaire Handler # # (C) Copyright 1997,1998 Dave Beckett # University of Kent at Canterbury # http://www.cs.ukc.ac.uk/people/staff/djb1/ # require 5.004; use strict; use File::Basename; use CGI; # CONFIGURATION # Configuration file containing the list of questionnaires $::configuration_file= './example/questionnaire.conf'; # Questionnaire usage log file $::log_file = './example/questionnaire.log'; # Results directory $::results_dir = './example/qresults'; # Email address of administrator $::administrator_email = 'apinto@eecs.berkeley.edu'; # END OF CONFIGURATION # GLOBAL VARIABLES # Tags recognised here @::questionnaire_tags=qw(QUESTIONNAIRE AUTHOR ANSWERS ANSWER QUESTION); %::is_questionnaire_tag=map {$_=>1} @::questionnaire_tags; # Questionnaire ID (for logging) $::qid=undef; $::VERSION=(split(/ /, q$Id: questionnaire.pl,v 1.15 1998/06/03 13:57:27 djb1 Exp $))[2]; # Necessary for tainting $::ENV{PATH}='/usr/bin/'; &main($::configuration_file, $::log_file, $::results_dir, $::administrator_email); exit 0; sub html_quote_string { my($string)=@_; $string =~ s/&/\&/g; $string =~ s//\>/g; $string; } sub html_header ($;$) { my($title,$header)=@_; $header=$title unless defined $header; return <<"EOT"; $title

$header

EOT } sub format_email_name_home ($;$$) { my($email, $name, $www)=@_; return 'Unknown' unless $email; $name=$email unless $name; my $url=$www || "mailto:$email"; return qq{$name <$email>}; } sub html_footer ($;$$) { my($admin_email, $admin_name, $admin_www)=@_; my $person=format_email_name_home($admin_email, $admin_name, $admin_www); return <<"EOT";

Generated by the Questionnaire handler V$::VERSION $person

EOT } sub parse_tag ($) { my($line)=@_; return (undef,undef,undef) unless $line =~ s%^<(/?)([^ >]+)\s*%%; my($is_end,$tag)=($1,uc $2); $is_end=0 if !defined $is_end; my(%attributes); if ($line =~ s/^>//) { ; # end of tag, nothing more } else { # Process attributes while(1) { $line=~ s/^\s+//; last if !$line || $line=~ s/^>//; if ($line =~ s/(\S+)\s*=\s*"([^"]*)"// || $line =~ s/(\S+)\s*=\s*'([^"]*)'// || $line =~ s/(\S+)\s*=\s*(\S+)// ) { my($name, $value)=(uc $1, $2); $attributes{$name}=($value || ''); } elsif ($line =~ s/(\S+)//) { my $name=uc $1; $attributes{$name}=undef; } else { ; # help, what should I do here? Just delete next token $line=~ s/^\S+//; } } # while(1) (attributes) } # if attributes return ($tag, $is_end, \%attributes); } sub read_configuration_file ($) { my $config_file=shift; my %config=(FILE => $config_file); if (!open(IN, $config_file)) { $config{ERRORS}=["Cannot open $config_file - $!\n"]; return \%config; } my(@id_order); my(@msgs); while() { chomp; s/^\s+//; next if !$_ || /^#/; my($tag,$is_end,$attributes)=parse_tag($_); if(!$tag) { push(@msgs, "$config_file:$.: Do not understand line '$_'"); next; } if ($tag ne 'QUESTIONNAIRE' || $is_end) { push(@msgs, "$config_file:$.: Do not understand use of tag $tag here"); next; } my $id=$attributes->{ID}; if (!defined $id) { push(@msgs, "$config_file:$.: No ID attribute present"); next; } elsif ($id =~ /^([-\w]+)$/) { $id=$1; } else { push(@msgs, "$config_file:$.: Illegal characters in ID $id"); } $config{IDS}->{$id}=$attributes; push(@id_order, $id); } close(IN); $config{ERRORS}=[@msgs] if @msgs; $config{ID_ORDER}=\@id_order; return \%config; } sub check_configuration ($) { my($configuration)=@_; my $config_file=$configuration->{FILE}; my(@msgs); # Check configuration for my $id (keys %{$configuration->{IDS}}) { my $bad=0; for my $attr (qw(PATH)) { if (!defined $configuration->{IDS}->{$id}->{$attr}) { push(@msgs, "Questionnaire $id: Missing attribute $attr"); $bad=1; } } next if $bad; #my $path=$configuration->{IDS}->{$id}->{PATH}; #my $enabled=uc($configuration->{IDS}->{$id}->{ENABLED} || 'YES'); #my $admin_password=$configuration->{IDS}->{$id}->{ADMIN_PASSWORD}; #my $user_password=$configuration->{IDS}->{$id}->{USER_PASSWORD}; } $configuration->{ERRORS}=[@msgs] if @msgs; } sub read_questionnaire ($) { my($quest_file)=@_; my(%q)=(FILE => $quest_file); if (!open(IN, $quest_file)) { $q{ERRORS}=["Cannot open $quest_file - $!\n"]; return \%q; } my(@output); my(@msgs); while() { chomp; s/^\s+//; next if !length $_; if (/^/) { push(@output, [$., '--', 0, $_]); } elsif (/^/; } push(@output, [$., '--', 0, $comment]); } elsif (/^[^<]/) { push(@output, [$., 'HTML', 0, $_]); } else { my($tag,$is_end,$attributes)=parse_tag($_); if (!$tag || !$::is_questionnaire_tag{$tag}) { push(@output, [$., 'HTML', 0, $_]); next; } push(@output, [$., $tag, $is_end, $attributes]); } } close(IN); $q{OUTPUT}=\@output; $q{ERRORS}=[@msgs] if @msgs; return \%q; } sub dump_questionnaire ($) { my($questionnaire)=@_; my $out=''; my $output=$questionnaire->{OUTPUT}; return $out if !$output; for my $bit (@$output) { my($line, $tag, $is_end, $content)=@$bit; if ($tag eq 'HTML' || $tag eq '--') { $out.= "HTML: ".html_quote_string($content)."\n"; } else { if ($is_end) { $out.= " </$tag>"; } else { $out.= " <$tag> Attributes: ".html_quote_string(join(" ", %$content)); } } $out.= "
\n"; } $out; } sub process_questionnaire ($$) { my($qid, $questionnaire)=@_; my $output=$questionnaire->{OUTPUT}; if (!defined $output) { $questionnaire->{ERRORS}=["No content found"]; return; } # Check is first tag { my($line, $tag, $is_end, $attr)=@{shift(@{$questionnaire->{OUTPUT}})}; if ($tag ne 'QUESTIONNAIRE' || $is_end) { $questionnaire->{ERRORS}=["Line $line: First tag is $tag, not "]; return; } my $doc_qid=$attr->{ID}; my $doc_title=$attr->{TITLE}; if (!$doc_qid || !$doc_title) { $questionnaire->{ERRORS}=["Line $line: Missing ID and/or TITLE attributes in "]; return; } if ($doc_qid ne $qid) { $questionnaire->{ERRORS}=["Line $line: Document ID $doc_qid does not match configuration file id $qid"]; return; } $questionnaire->{TITLE}=$doc_title; my $extras=uc($attr->{EXTRAS} || 'some'); if ($extras !~ /^(?:NONE|SOME|ALL)$/) { $questionnaire->{ERRORS}=["Line $line: EXTRA value $extras is not one of NONE, SOME or ALL"]; return; } $questionnaire->{EXTRAS}=$extras; # Legacy _s for jwl my $start_date =$attr->{STARTDATE} || $attr->{START_DATE}; my $end_date =$attr->{ENDDATE} || $attr->{END_DATE}; my(@msgs); # Check values if ($start_date && $start_date !~ /^\d\d\d\d-\d\d-\d\d/) { push(@msgs, "Line $line: Start date '$start_date' does not match YYYY-MM-DD"); } if ($end_date && $end_date !~ /^\d\d\d\d-\d\d-\d\d/) { push(@msgs, "Line $line: End date '$end_date' does not match YYYY-MM-DD"); } if ($start_date && $end_date && $start_date gt $end_date) { push(@msgs, "Line $line: Start date $start_date is after end date $end_date"); } $questionnaire->{START_DATE}=$start_date if $start_date; $questionnaire->{END_DATE}=$end_date if $end_date; } # Check is next tag { my($line, $tag, $is_end, $attr)=@{shift(@{$questionnaire->{OUTPUT}})}; if ($tag ne 'AUTHOR' || $is_end) { $questionnaire->{ERRORS}=["Line $line: Second tag is $tag, not \n"]; return; } my $author_email=$attr->{EMAIL}; my $author_name=$attr->{NAME}; my $author_www=$attr->{HOMEPAGE}; if (!$author_email || !$author_name) { $questionnaire->{ERRORS}=["Line $line: Missing NAME and/or EMAIL attributes"]; return; } if ($author_email !~ /@/) { $questionnaire->{ERRORS}=["Line $line: $author_email does not look like an email address"]; return; } $questionnaire->{AUTHOR_NAME}=$author_name; $questionnaire->{AUTHOR_EMAIL}=$author_email; $questionnaire->{AUTHOR_HOMEPAGE}=$author_www; } # Now fill out sections with answers etc. my $section_counter=0; my %sections; my %questions; my $question_counter=0; my(@msgs); my %answers=(); my $nanswers=0; my $in_answers=0; while(my $bit=shift(@$output)) { my($line,$tag,$is_end,$content)=@$bit; if ($tag eq 'HTML' || $tag eq '--') { $sections{$section_counter}={TYPE => 'HTML', DATA => $content}; $section_counter++; } elsif ($tag eq 'ANSWERS') { if ($is_end) { $in_answers=0; } elsif ($in_answers) { push(@msgs, "Line $line: Found ANSWERS inside ANSWERS"); next; } else { $in_answers=1; %answers=(); $nanswers=0; } } elsif ($tag eq 'ANSWER') { if (!$in_answers) { push(@msgs, "Line $line: Found ANSWER outside ANSWERS"); next; } my $label=$content->{LABEL}; my $value=$content->{VALUE}; if (defined $label && !defined $value) { $value=$nanswers+1; } elsif (defined $value && !defined $label) { $label=$value; } elsif (!defined $value && !defined $label) { push(@msgs, "Line $line: Found answer with no LABEL or VALUE attribute"); next; } $answers{$nanswers}={ LABEL => $label, VALUE => $value, }; $nanswers++; } elsif ($tag eq 'QUESTION') { $question_counter++; my $name =$content->{NAME}; my $type =lc($content->{TYPE} || 'closed'); my $value =$content->{VALUE}; my $width =$content->{WIDTH}; my $height =$content->{HEIGHT}; my $required =uc($content->{REQUIRED} || 'NO'); my $style =uc($content->{STYLE} || 'RADIO'); if (!$name) { push(@msgs, "Line $line: Found question with no NAME attribute"); next; } elsif (defined $questions{$name}) { push(@msgs, "Line $line: Found duplicate question name $name"); next; } if ($type ne 'open' && $type ne 'closed') { push(@msgs, "Line $line: Found unknown question type $type inside QUESTION $name"); next; } # Get content my $content=''; while(my $qbit=shift(@$output)) { my($line,$qtag,$qis_end,$qcontent)=@$qbit; last if $qtag eq 'QUESTION' && $qis_end; if ($qtag eq 'HTML') { $content.="\n" if $content; $content.=$qcontent; next; } $qtag="/$qtag" if $qis_end; push(@msgs, "Line $line: Do not understand tag $qtag inside QUESTION $name"); } if (!length $content) { $content="Question $name (no description given)"; } $questions{$name}->{TYPE}=$type; $questions{$name}->{COUNT}=$question_counter; $questions{$name}->{LABEL}=$content; $questions{$name}->{REQUIRED}=$required; $questions{$name}->{STYLE}=$style; if ($type eq 'closed') { my(%labels); my(@values); my %valid_answers; for my $anum (0..$nanswers-1) { my $avalue=$answers{$anum}->{VALUE}; $labels{$avalue}=$answers{$anum}->{LABEL}; $valid_answers{$avalue}=1; push(@values, $avalue); } $questions{$name}->{ANSWER_LABELS}=\%labels; $questions{$name}->{ANSWER_VALUES}=\@values; if (defined $value) { if(!defined $valid_answers{$value}) { push(@msgs, "Line $line: Found default value $value for QUESTION $name which is not one of the valid answers"); next; } $questions{$name}->{DEFAULT}=$value; } } else { # open $questions{$name}->{WIDTH}=$width if $width; $questions{$name}->{HEIGHT}=$height if $height; $questions{$name}->{DEFAULT}=$value if defined $value; } $sections{$section_counter}={TYPE => 'QUESTION', DATA => $name}; $section_counter++; } elsif ($tag eq 'QUESTIONNAIRE') { ; # end - do nothing } else { $tag="/$tag" if $is_end; push(@msgs, "Do not understand output tag $tag"); } } # Done with this $questionnaire->{OUTPUT}=undef; $questionnaire->{ID}=$qid; $questionnaire->{SECTIONS}=\%sections; $questionnaire->{NSECTIONS}=$section_counter; $questionnaire->{QUESTIONS}=\%questions; $questionnaire->{NQUESTIONS}=$question_counter; $questionnaire->{ERRORS}=[@msgs] if @msgs; } sub print_questionnaire ($$) { my($questionnaire, $query)=@_; my $qid=$questionnaire->{ID}; my $sections=$questionnaire->{SECTIONS}; my $nsections=$questionnaire->{NSECTIONS}; my $questions=$questionnaire->{QUESTIONS}; my $nquestions=$questionnaire->{NQUESTIONS}; print $query->startform(-method=>'POST', -action=> $query->url); print $query->hidden(-name => "qid", -value => "$qid"), "\n\n"; print "\n\n"; for my $section (0..$nsections-1) { my $type=$sections->{$section}->{TYPE} || '(undefined)'; my $name=$sections->{$section}->{DATA} || '(undefined)'; #print "\n"; if ($type eq 'HTML') { print $name. "\n"; } elsif ($type eq 'QUESTION') { print "\n"; my $result=$questions->{$name}->{RESULT}; # If this has already been filled in correctly, just insert answer if (defined $result) { my $value=$query->param($name); $value =~ s/\n/!!NEWLINE!!/g; # Use spaces, not white space $value =~ s/\s+/ /g; print $query->hidden(-name =>$name), "\n"; next; } my $required=$questions->{$name}->{REQUIRED}; my $count=$questions->{$name}->{COUNT}; my $label=$questions->{$name}->{LABEL}; my $default=$questions->{$name}->{DEFAULT}; my $req=($required eq 'YES')? " (Answer Required) " : ''; print "

$count. $req\n"; #print "

$count.\n"; print "$label\n\n"; my(%args)=(-name => $name); $args{-default}=$default if defined $default; my $type=$questions->{$name}->{TYPE}; if ($type eq 'closed') { my $labels=$questions->{$name}->{ANSWER_LABELS}; my $values=$questions->{$name}->{ANSWER_VALUES}; my $style=$questions->{$name}->{STYLE}; if ($style eq 'MENU') { if(!defined $default) { $default=''; $values=[$default, @$values]; $labels->{$default}='(No answer)'; $args{-default}=$default; } $args{-labels}=$labels; $args{'-values'}=$values; print $query->popup_menu(%args); } elsif ($style eq 'RADIO') { $args{-labels}=$labels; $args{'-values'}=$values; $args{-default}='-' if !defined $default; print $query->radio_group(%args); } else { print "

Unknown question output style $style

\n"; } } else { my $width=$questions->{$name}->{WIDTH} || 50; my $height=$questions->{$name}->{HEIGHT} || 5; if($height eq '1') { $args{-size}=$width; print $query->textfield(%args); } else { $args{-cols}=$width; $args{-rows}=$height; print $query->textarea(%args); } } print "\n"; } else { print "

Unknown section type $type, content $name

\n"; } } print "

\n"; print $query->submit(-name=>'Submit Form'); print $query->endform; } sub check_questionnaire_complete ($$) { my($questionnaire, $query)=@_; my $sections=$questionnaire->{SECTIONS}; my $nsections=$questionnaire->{NSECTIONS}; my $questions=$questionnaire->{QUESTIONS}; my(@msgs); my %results; for my $section (0..$nsections-1) { next unless $sections->{$section}->{TYPE} eq 'QUESTION'; my $name=$sections->{$section}->{DATA}; my $count=$questions->{$name}->{COUNT}; my $label=$questions->{$name}->{LABEL}; my $type=$questions->{$name}->{TYPE}; my $required=$questions->{$name}->{REQUIRED}; my $style=$questions->{$name}->{STYLE}; my $p=$query->param($name); if (defined $p) { # Remove leading spaces $p=~ s/^\s+//; $p=~ s/\s+$//; #$p=~ s/\s+/ /g; $p=undef if !length $p; } if (defined $p) { $questions->{$name}->{RESULT}= $results{$name}= $p; } elsif ($required eq 'YES') { push(@msgs, "Question $count: An answer is required."); } elsif ($type eq 'closed') { push(@msgs, "Question $count: No answer was chosen from the list of answers."); } } $questionnaire->{RESULTS}=\%results; $questionnaire->{ERRORS}=[@msgs] if @msgs; } sub is_tainted { not eval { my $dummy=join("", @_), kill 0; 1; }; } sub submit_questionnaire ($$$$) { my($questionnaire, $query, $results_dir, $host)=@_; my $results=$questionnaire->{RESULTS}; my $qid=$questionnaire->{ID}; my $sections=$questionnaire->{SECTIONS}; my $nsections=$questionnaire->{NSECTIONS}; my $questions=$questionnaire->{QUESTIONS}; my $title=$questionnaire->{TITLE}; my $author_name=$questionnaire->{AUTHOR_NAME}; my $author_email=$questionnaire->{AUTHOR_EMAIL}; my $extras=$questionnaire->{EXTRAS}; my $subject="Questionnaire: $title ($qid) Results"; $subject =~ tr/'//d; my $cmd="mailx -s '$subject' $author_email\n"; if (!open(PIPE,"|$cmd")) { $questionnaire->{ERRORS}=["Failed to create pipe $cmd - $!\n"]; return; } for my $section (0..$nsections-1) { next unless $sections->{$section}->{TYPE} eq 'QUESTION'; my $name=$sections->{$section}->{DATA}; my $value=$questions->{$name}->{RESULT} || ''; $value =~ s/!!NEWLINE!!/\n/g; $value=~s/\n/\n\t/g; print PIPE "$name: $value\n"; } if ($extras ne 'NONE') { print PIPE "\n\n"; if ($extras eq 'SOME') { print PIPE "# Results submitted by user at $host\n" if defined $host; my $ref=$::ENV{'HTTP_REFERER'}; print PIPE "# Refering URL: $ref\n" if defined $ref; } else { my(@envars)=sort grep(/^HTTP/, keys %::ENV); print PIPE "# ",join("\n# ", map "$_: $::ENV{$_}", @envars),"\n"; } } close(PIPE); # Now store results in files too # Make these results group writable umask 007; if(open(OUT, ">>$results_dir/$qid")) { $query->save('OUT'); close(OUT); } else { log_message("Failed to create $results_dir/results - $!"); } } sub set_qid ($) { $::qid=shift; } sub get_qid () { $::qid; } sub log_messages($) { my($msgs)=@_; if(open(LOG, ">>$::log_file")) { my $r=$::ENV{REMOTE_HOST} || $::ENV{REMOTE_ADDR}; # Untainting my $rhost='-'; $rhost=$1 if $r =~ /^(.+)$/; my $prefix="$rhost [".(scalar localtime time)."] "; my $qid=get_qid || '-'; $prefix.="$qid "; for my $msg (@$msgs) { print LOG $prefix,$msg,"\n"; } close(LOG); } } sub log_message($) { log_messages([shift]); } sub fatal ($$$;$$) { my($header,$errs,$email,$name,$www)=@_; log_messages($errs); print html_header($header); print "

\n",join("
\n",map {html_quote_string($_)} @$errs),"\n

"; print html_footer($email,$name,$www); exit 0; } sub main { my($config_file, $log_file, $results_dir, $admin_email)=@_; # Unbuffer output $|=1; # Mozilla/3.02 seems to cause this warning sequence: # --- # Use of uninitialized value at .../5.00404/CGI.pm line 405. # [Wed Dec 17 11:29:35 1997] lingering close lost connection to client foo.ukc.ac.uk # [Wed Dec 17 11:34:12 1997] read request headers timed out for foo.ukc.ac.uk # --- # And the offending line(s) are: # --- # 405: $self->read_from_client(\*STDIN,\$query_string,$ENV{'CONTENT_LENGTH'},0) # 406: if $ENV{'CONTENT_LENGTH'} > 0; # --- # and then script returns with error 408 - Request Timeout # when it fails to read the HTTP headers. $ENV{'CONTENT_LENGTH'}=0 if !defined $ENV{'CONTENT_LENGTH'}; my $query=new CGI; my $host=$::ENV{REMOTE_HOST} || $::ENV{REMOTE_ADDR} || '-'; print "$::VERSION\n" and return if $query->param('version'); if ($query->param('docs') || $query->param('userdocs')) { print $query->header(-type=>'text/html') unless $query->param('userdocs'); print html_header("Questionnaire Documentation"); $query->delete_all; my $self_url=$query->self_url; # From __DATA__ section below for my $line () { $line =~ s/\@CONFIGURATION_FILE\@/$config_file/g; $line =~ s/\@SELF_URL\@/$self_url/g; print $line; } print html_footer($admin_email); return; } my $qid=$query->param('qid'); if (defined $qid) { print $query->header(-type=>'text/html', -expires=>'now'); } else { print $query->header(-type=>'text/html'); } my $configuration=read_configuration_file($config_file); if (my $errs=$configuration->{ERRORS}) { fatal("Failed to read configuration file", $errs, $admin_email); } check_configuration($configuration); if (my $errs=$configuration->{ERRORS}) { fatal("Problems in configuration file $config_file", $errs, $admin_email); } my(@errs); # Validate qid if present if (defined $qid) { if(!defined $configuration->{IDS}->{$qid}) { push(@errs, "No questionnaire with ID $qid present"); $qid=undef; } elsif ($qid =~ /^([-\w]+)$/) { $qid=$1; } else { push(@errs, "Illegal characters in ID $qid"); } } if (@errs) { fatal("Questionnaire ID Problems", \@errs, $admin_email); } # If no qid given, list the questionnaires available if (!defined $qid) { print html_header("Available Questionnaires"); print qq{

The current questionnaires in $config_file are:

\n\n}; print "

"; my $state=($enabled eq 'YES') ? 'Enabled' : 'Disabled'; if (!-r $path) { $state='Disabled (file is not readable)'; } my($mday,$mon,$year)=(localtime time)[3,4,5]; my $date=sprintf("%04d-%02d-%02d",1900+$year,$mon+1,$mday); if ($start_date && $date lt $start_date) { $state='Disabled (before valid period)'; } if ($end_date && $date gt $end_date) { $state='Disabled (after valid period)'; } $query->delete_all; $query->param('qid', $id); print qq{$anchor_text$anchor_moretext
\n}; my $author=format_email_name_home($author_email, $author_name, $author_homepage); my(@lines)=("Author: $author", "State: $state"); push(@lines, "Extra information: ".lc $extras) if $extras; push(@lines, "Some errors are present - follow the link above to see them.") if $errs; my $valid=''; $valid="from $start_date" if $start_date; if ($end_date) { $valid.=' ' if $valid; $valid.="till $end_date"; } push(@lines, "Valid $valid") if $valid; push(@lines, qq{ Source: $path}); print ": ",join("
\n ",@lines),"\n\n";; } print "

\n"; $query->delete_all; $query->param('docs', 1); print qq{Documentation for the questionnaire system.\n}; print html_footer($admin_email); return; } set_qid($qid); my $path=$configuration->{IDS}->{$qid}->{PATH}; my $enabled=uc($configuration->{IDS}->{$qid}->{ENABLED} || 'YES'); if ($enabled ne 'YES') { fatal("Questionnaire $qid disabled", ["Questionnaire $qid is not enabled for use."], $admin_email); } my $questionnaire=read_questionnaire($path); if (my $errs=$questionnaire->{ERRORS}) { fatal("Failed to read questionnaire file", $errs, $admin_email); return; } process_questionnaire($qid, $questionnaire); if (my $errs=$questionnaire->{ERRORS}) { fatal("Problem in questionnaire file ".$questionnaire->{FILE}, $errs, $admin_email); } # Configuration is now valid, so can get these my $title=$questionnaire->{TITLE}; my $author_name=$questionnaire->{AUTHOR_NAME}; my $author_email=$questionnaire->{AUTHOR_EMAIL}; my $author_homepage=$questionnaire->{AUTHOR_HOMEPAGE}; my($mday,$mon,$year)=(localtime time)[3,4,5]; my $date=sprintf("%04d-%02d-%02d",1900+$year,$mon+1,$mday); my $start_date=$questionnaire->{START_DATE}; if ($start_date && $date lt $start_date) { fatal("Questionnaire $qid disabled", ["Questionnaire $title (ID $qid) is not yet available, it will become accessible on $start_date."], $author_email, $author_name, $author_homepage); } my $end_date=$questionnaire->{END_DATE}; if ($end_date && $date gt $end_date) { fatal("Questionnaire $qid disabled", ["Questionnaire $title (ID $qid) is no longer available, it was last available on $end_date."], $author_email, $author_name, $author_homepage); } # New form if only parameter was qid if(scalar($query->param)==1) { print html_header($title); print_questionnaire($questionnaire, $query); print html_footer($author_email, $author_name, $author_homepage); return; } check_questionnaire_complete($questionnaire, $query); if (my $errs=$questionnaire->{ERRORS}) { print html_header("Questionnaire $title Incomplete","Questionnaire $title Incomplete"); print "

\n",join("
\n",map {html_quote_string($_)} @$errs),"\n

"; print "

\n"; print_questionnaire($questionnaire, $query); print html_footer($author_email, $author_name, $author_homepage); log_messages($errs); return; } # Must be done if no errors submit_questionnaire($questionnaire, $query, $results_dir, $host); if (my $errs=$questionnaire->{ERRORS}) { fatal("Problems in Submitting Questionnaire $title ", $errs, $admin_email); } print html_header("Questionnaire $title Done"); print "

Your answers have been submitted.

\n"; print "

Thank you for participating.

\n"; print html_footer($author_email, $author_name, $author_homepage); log_message("Submitted OK"); } # The documentation starts here. Perl allows use of this area # via the special file handle DATA __DATA__ There are three steps needed to create a new questionnaire using this system -- a questionnaire template must be created, the main configuration file must be updated to point to it and the questionnaire must be tested.

1. Questionnaire Template

Each questionnaire has a HTML-like template file that includes the questions, answers and various other elements. The elements that are used are defined as follows:

QUESTIONNAIRE

Required outer tag delimiting the scope of the operation. Attributes:

ID

Required. An identifier that matches that in the configuration file. It can contain letters, numbers, _ and -.

TITLE

Title of the questionnaire (and web page)

EXTRAS

Optional. This records the additional information sent with the email to the author and can take three values: NONE, SOME and ALL.

NONE: No extra information is sent.
SOME (default): will send the host name and refering URL.
ALL: Sends all HTTP headers that it can.

STARTDATE

First date at which the questionnaire is active, in form YYYY-MM-DD.

ENDDATE

Last date at which this questionnaire can be used, in form YYYY-MM-DD.

AUTHOR

Required tag to describe the author of the questionnaire; all attributes are also required to be entered. Attributes:

NAME: Required. Name of author of questionnaire.
EMAIL: Required. Email address of author of questionnaire.
HOMEPAGE: Optional. WWW (or other) location for author of questionnaire.

ANSWERS

Set the answers for the closed questions (i.e those with a limited set of responses). If this tag is not given, the answers (and visible labels) will be set to 1..n for the questions. Inside this tag there can only be a list of ANSWER tags:

ANSWER

Attributes:

LABEL: Required if no VALUE is given. Set the visible label for this answer. The value returned to the author is set to n for the nth answer if no label is given.
VALUE: Required if no LABEL is given. Sets the value of the answer returned to the author as the result. If no LABEL is given, also sets the label for the answer.

QUESTION

One question is required, to make a questionnaire! Attributes:

NAME: Required. Defines the name or field name of this question which must be unique for the questionnaire. This is the name seen when the results are submitted.
TYPE: Set the type of the question. The default is closed which uses the ANSWER values as closed answers to the question. If open is used, a larger text area is displayed that can be used to enter free text. In this case, the WIDTH and HEIGHT attributes can also be used to customize the shape of the field.
VALUE: Set a default response for the question. Use this with care.
REQUIRED: By default, an answer is required for closed questions and optional for open questions. Use this option to make open questions required also by setting the value to YES. It is recommended that if no answer is allowed for closed questions, you make an 'No answer' choice in the list of ANSWERS, and you can then optionally also make it the default.
WIDTH and HEIGHT: Set the width and height of the open question field. Ignored for closed questions.
STYLE: For closed questions allow the choice of RADIO buttons or a MENU of options for the user to pick .

The contents of the QUESTION tag are the text to display to the user.

Example template

Do not put anything before the QUESTIONNAIRE tag

<QUESTIONNAIRE ID="qid-1" TITLE="Questionnaire about foo">

<AUTHOR NAME="Your Name" EMAIL="A.User@ukc.ac.uk">

<!-- Used to label regular questions -->
<ANSWERS>
<ANSWER LABEL="Very likely">
<ANSWER LABEL="Somewhat likely">
<ANSWER LABEL="Undecided">
<ANSWER LABEL="Unlikely">
<ANSWER LABEL="Very unlikely">
</ANSWERS>

Any HTML you like can appear outside these tags.

<QUESTION NAME="Name" REQUIRED="Yes" TYPE="closed" HEIGHT="1">
Please Enter your Name
</QUESTION>


<QUESTION NAME="question-1">
I think the course was wonderful.

<P>
</QUESTION>

<-- By default VALUES are set 1.. n -->
<ANSWERS>
<ANSWER VALUE="5" LABEL="Very likely">
<ANSWER VALUE="4" LABEL="Somewhat likely">
<ANSWER VALUE="3" LABEL="Undecided">
<ANSWER VALUE="2" LABEL="Unlikely">
<ANSWER VALUE="1" LABEL="Very unlikely">
</ANSWERS>

.
.
.


<QUESTION NAME="other-comments" TYPE="open" VALUE="Your comments here">
Any other comments
</QUESTION>

</QUESTIONNAIRE>

Put more HTML here if you want but the resulting page will be finished with the usual HTML closing tags.

Other examples can be found from the list of questionnaires already installed, see below.

2. The Main Configuration File

This file holds the list of supported questionnaires which may include ones that are not yet enabled.

Currently this file is @CONFIGURATION_FILE@ and looks something like this:

<QUESTIONNAIRE ID="qid-1" PATH="/home/auser/qid1.quest">
<QUESTIONNAIRE ID="user2-other" PATH="/user2/other.quest" ENABLED="no">

Note: Each tag must be on a single line in the style above

The questionnaire files must be readable to the web server i.e. should be visible to 'other' in UNIX permissions terminology and The ID given must match the one in the questionaire stored in the file PATH.

QUESTIONNAIRE

Detailed Attributes:

ID: Required. An identifier which matches that in the questionnaire file. It can contain letters, numbers, _ and -.
PATH: Required. File name of this questionnaire
ENABLED: A flag to allow use of the questionnaire.

3. Testing and Publishing

The root URL of the questionnaire CGI program is:
@SELF_URL@

You can select this link to see a list of all questionnaires in the configuration file. An entry for your questionnaire should be visible - check that it is enabled and that no errors are reported. You can then either copy the link location using your web browser or construct it yourself:
@SELF_URL@?qid=ID
where ID is the one for your questionnaire.

This link can then be given out or added to any web page.

The results of the form submissions will be emailed to you on submission. It is strongly recommended that you try this out before publishing the URL to check everything is working.

Author

Dave Beckett, D.J.Beckett@ukc.ac.uk.