1366 lines
43 KiB
Perl
1366 lines
43 KiB
Perl
package WebGUI::Asset::Wobject::Survey::ResponseJSON;
|
|
|
|
=head1 LEGAL
|
|
|
|
-------------------------------------------------------------------
|
|
WebGUI is Copyright 2001-2009 Plain Black Corporation.
|
|
-------------------------------------------------------------------
|
|
Please read the legal notices (docs/legal.txt) and the license
|
|
(docs/license.txt) that came with this distribution before using
|
|
this software.
|
|
-------------------------------------------------------------------
|
|
http://www.plainblack.com info@plainblack.com
|
|
-------------------------------------------------------------------
|
|
|
|
=head1 NAME
|
|
|
|
Package WebGUI::Asset::Wobject::Survey::ResponseJSON
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Helper class for WebGUI::Asset::Wobject::Survey. The class deals with both a
|
|
"reponse" in the sense of an overall Survey response, and also "response" in
|
|
the sense of a single Question response (which is closely related to an Answer but
|
|
not quite the same).
|
|
|
|
As a whole, this class represents the complete state of a user's response to a Survey instance.
|
|
|
|
At the heart of this class is a perl hash that can be serialized
|
|
as JSON to the database to allow for storage and retrieval of the complete state
|
|
of a survey response.
|
|
|
|
Survey instances that allow users to record multiple responses will persist multiple
|
|
instances of this class to the database (one per distinct user response).
|
|
|
|
Data stored in this object include the order in which questions and answers are
|
|
presented to the user (L<"surveyOrder">), a snapshot of all completed questions
|
|
from the user (L<"responses">), the most recently answered question (L<"lastResponse">), the
|
|
number of questions answered (L<"questionsAnswered">) and the Survey start time (L<"startTime">).
|
|
|
|
This package is not intended to be used by any other Asset in WebGUI.
|
|
|
|
=cut
|
|
|
|
use strict;
|
|
use JSON;
|
|
use Params::Validate qw(:all);
|
|
use List::Util qw(shuffle);
|
|
use Safe;
|
|
Params::Validate::validation_options( on_fail => sub { WebGUI::Error::InvalidParam->throw( error => shift ) } );
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 new ( $survey, $json )
|
|
|
|
Object constructor.
|
|
|
|
=head3 $survey
|
|
|
|
A L<WebGUI::Asset::Wobject::Survey::SurveyJSON> object that represents the current
|
|
survey.
|
|
|
|
=head3 $json
|
|
|
|
A JSON string used to construct a new Perl object. The string should represent
|
|
a JSON hash made up of L<"startTime">, L<"surveyOrder">, L<"responses">, L<"lastResponse">
|
|
and L<"questionsAnswered"> keys, with appropriate values.
|
|
|
|
=cut
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
my ($survey, $json) = validate_pos(@_, {isa => 'WebGUI::Asset::Wobject::Survey::SurveyJSON' }, { type => SCALAR | UNDEF, optional => 1});
|
|
|
|
# Load json object if given..
|
|
my $jsonData = $json ? from_json($json) : {};
|
|
|
|
# Create skeleton object..
|
|
my $self = {
|
|
# First define core members..
|
|
_survey => $survey,
|
|
_session => $survey->session,
|
|
|
|
# Store all properties that are (de)serialized to/from JSON in a private variable
|
|
_response => {
|
|
|
|
# Response hash defaults..
|
|
responses => {},
|
|
lastResponse => -1,
|
|
questionsAnswered => 0,
|
|
startTime => time(),
|
|
surveyOrder => undef,
|
|
|
|
# And then allow jsonData to override defaults and/or add other members
|
|
%{$jsonData},
|
|
},
|
|
};
|
|
|
|
return bless $self, $class;
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
|
|
=head2 initSurveyOrder
|
|
|
|
Computes and stores the order of Sections, Questions and Aswers for this Survey.
|
|
See L<"surveyOrder">. You normally don't need to call this, as L<"surveyOrder"> will
|
|
call it for you the first time it is used.
|
|
|
|
Questions and Answers that are set to be randomized are shuffled into a random order.
|
|
|
|
=cut
|
|
|
|
sub initSurveyOrder {
|
|
my $self = shift;
|
|
|
|
# Order Questions in each Section
|
|
my @surveyOrder;
|
|
for my $sIndex ( 0 .. $self->survey->lastSectionIndex ) {
|
|
|
|
# Randomize Questions if required..
|
|
my @qOrder;
|
|
if ( $self->survey->section( [$sIndex] )->{randomizeQuestions} ) {
|
|
@qOrder = shuffle 0 .. $self->survey->lastQuestionIndex( [$sIndex] );
|
|
}
|
|
else {
|
|
@qOrder = ( 0 .. $self->survey->lastQuestionIndex( [$sIndex] ) );
|
|
}
|
|
|
|
# Order Answers in each Question
|
|
for my $q (@qOrder) {
|
|
|
|
# Randomize Answers if required..
|
|
my @aOrder;
|
|
if ( $self->survey->question( [ $sIndex, $q ] )->{randomizeAnswers} ) {
|
|
@aOrder = shuffle 0 .. $self->survey->lastAnswerIndex( [ $sIndex, $q ] );
|
|
}
|
|
else {
|
|
@aOrder = ( 0 .. $self->survey->lastAnswerIndex( [ $sIndex, $q ] ) );
|
|
}
|
|
push @surveyOrder, [ $sIndex, $q, \@aOrder ];
|
|
}
|
|
|
|
# If Section had no Questions, make sure it is still added to @surveyOrder
|
|
if ( !@qOrder ) {
|
|
push @surveyOrder, [$sIndex];
|
|
}
|
|
}
|
|
$self->response->{surveyOrder} = \@surveyOrder;
|
|
|
|
return;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 session
|
|
|
|
Accessor method for the WebGUI::Session reference
|
|
|
|
=cut
|
|
|
|
sub session {
|
|
my $self = shift;
|
|
return $self->{_session};
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 freeze
|
|
|
|
Serializes the internal perl hash representing the Response to a JSON string
|
|
|
|
=cut
|
|
|
|
sub freeze {
|
|
my $self = shift;
|
|
return to_json($self->response);
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 hasTimedOut ( $limit )
|
|
|
|
Checks to see whether this survey has timed out, based on the internally stored starting
|
|
time, and the suppied $limit value.
|
|
|
|
=head3 $limit
|
|
|
|
How long the user has to take the survey, in minutes.
|
|
|
|
=cut
|
|
|
|
sub hasTimedOut{
|
|
my $self = shift;
|
|
my ($limit) = validate_pos(@_, {type => SCALAR});
|
|
return $limit > 0 && $self->startTime + $limit * 60 < time;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 lastResponse ([ $responseIndex ])
|
|
|
|
Mutator. The lastResponse property represents the surveyOrder index of the most recent item shown.
|
|
|
|
This method returns (and optionally sets) the value of lastResponse.
|
|
|
|
=head3 $responseIndex (optional)
|
|
|
|
If defined, lastResponse is set to $responseIndex.
|
|
|
|
=cut
|
|
|
|
sub lastResponse {
|
|
my $self = shift;
|
|
my ($responseIndex) = validate_pos(@_, {type => SCALAR, optional => 1});
|
|
|
|
if ( defined $responseIndex ) {
|
|
$self->response->{lastResponse} = $responseIndex;
|
|
}
|
|
|
|
return $self->response->{lastResponse};
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 questionsAnswered ([ $questionsAnswered ])
|
|
|
|
Mutator for the number of questions answered.
|
|
Returns (and optionally sets) the value of questionsAnswered.
|
|
|
|
=head3 $questionsAnswered (optional)
|
|
|
|
If defined, increments the number of questions by $questionsAnswered
|
|
|
|
=cut
|
|
|
|
sub questionsAnswered {
|
|
my $self = shift;
|
|
my ($questionsAnswered) = validate_pos(@_, {type => SCALAR, optional => 1});
|
|
|
|
if ( defined $questionsAnswered ) {
|
|
$self->response->{questionsAnswered} += $questionsAnswered;
|
|
}
|
|
|
|
return $self->response->{questionsAnswered};
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 startTime ([ $startTime ])
|
|
|
|
Mutator for the time the user began the survey.
|
|
Returns (and optionally sets) the value of startTime.
|
|
|
|
=head3 $startTime (optional)
|
|
|
|
If defined, sets the starting time to $startTime.
|
|
|
|
=cut
|
|
|
|
sub startTime {
|
|
my $self = shift;
|
|
my ($startTime) = validate_pos(@_, {type => SCALAR, optional => 1});
|
|
|
|
if ( defined $startTime ) {
|
|
$self->response->{startTime} = $startTime;
|
|
}
|
|
|
|
return $self->response->{startTime};
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 surveyOrder
|
|
|
|
Accessor. Initialized on first access via L<"initSurveyOrder">.
|
|
|
|
This data strucutre represents the list of items that are shown to the user, in the order
|
|
that they will be shown (ignoring jumps and jump expressions).
|
|
|
|
Typically each item will correspond to a question, and contains enough information to look
|
|
up both the corresponding section and all contained answers (if any).
|
|
|
|
Empty sections also appear in the list.
|
|
|
|
Each element of the array is an address, similar in structure to
|
|
L<WebGUI::Asset::Wobject::Survey::SurveyJSON/Address Parameter>,
|
|
except that instead of an answerIndex in the third slot, we have a sub-array of all contained answer indicies.
|
|
|
|
[ $sectionIndex, $questionIndex, [ $answerIndex1, $answerIndex2, ....]
|
|
|
|
By making use of L<WebGUI::Asset::Wobject::Survey::SurveyJSON> methods which expect address params as
|
|
arguments, you can access Section/Question/Answer items in order by iterating over surveyOrder.
|
|
|
|
For example:
|
|
|
|
# Access sections in order..
|
|
for my $address (@{ $self->surveyOrder }) {
|
|
my $section = $self->survey->section( $address );
|
|
# etc..
|
|
}
|
|
|
|
=cut
|
|
|
|
sub surveyOrder {
|
|
my $self = shift;
|
|
|
|
if (!defined $self->response->{surveyOrder}) {
|
|
$self->initSurveyOrder();
|
|
}
|
|
|
|
return $self->response->{surveyOrder};
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 nextResponse ([ $responseIndex ])
|
|
|
|
Mutator. The index of the next item that should be shown to the user,
|
|
that is, the index of the next item in the L<"surveyOrder"> array,
|
|
e.g. L<"lastResponse"> + 1.
|
|
|
|
=head3 $responseIndex (optional)
|
|
|
|
If defined, nextResponse is set to $responseIndex.
|
|
|
|
=cut
|
|
|
|
sub nextResponse {
|
|
my $self = shift;
|
|
my ($responseIndex) = validate_pos(@_, {type => SCALAR, optional => 1});
|
|
|
|
if ( defined $responseIndex ) {
|
|
$self->lastResponse($responseIndex - 1);
|
|
}
|
|
|
|
return $self->lastResponse() + 1
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 nextResponseSectionIndex
|
|
|
|
Returns the Section index of the next item that should be
|
|
shown to the user, that is, the next item in the L<"surveyOrder"> array
|
|
relative to L<"lastResponse">.
|
|
|
|
We go to the effort of calling this property "nextResponseSectionIndex"
|
|
rather than just "nextSectionIndex" to emphasize that this property is
|
|
distinct from the "next" section index in the Survey. For example, in
|
|
a Section with multiple Questions, the value of nextResponseSectionIndex
|
|
will be the same value (the current section index) for all Questions
|
|
except the last Question.
|
|
|
|
=cut
|
|
|
|
sub nextResponseSectionIndex {
|
|
my $self = shift;
|
|
return undef if $self->surveyEnd();
|
|
return $self->surveyOrder->[ $self->nextResponse ]->[0];
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 nextResponseSection
|
|
|
|
Returns the Section corresponding to the next item that should be
|
|
shown to the user, that is, the next item in the L<"surveyOrder"> array
|
|
relative to L<"lastResponse">.
|
|
|
|
As with L<"nextResponseSectionIndex">, we go to the effort of calling this property "nextResponseSection"
|
|
rather than just "nextSection" to emphasize that this property is
|
|
distinct from the "next" section in the Survey.
|
|
|
|
=cut
|
|
|
|
sub nextResponseSection {
|
|
my $self = shift;
|
|
|
|
return {} if $self->surveyEnd();
|
|
return $self->survey->section( [ $self->nextResponseSectionIndex ] );
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 lastResponseSectionIndex
|
|
|
|
Returns the Section index of the last item that was shown to the user,
|
|
based on the L<"surveyOrder"> array and L<"lastResponse">.
|
|
|
|
=cut
|
|
|
|
sub lastResponseSectionIndex {
|
|
my $self = shift;
|
|
return $self->surveyOrder->[ $self->lastResponse ]->[0];
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 recordResponses ($responses)
|
|
|
|
Processes and records submitted survey responses in the L<"responses"> data structure.
|
|
Does terminal handling, and branch processing, and advances the L<"lastResponse"> index
|
|
if all required questions have been answered.
|
|
|
|
=head3 $submittedResponses
|
|
|
|
A hash ref of submitted form param data. Each element should look like:
|
|
|
|
{
|
|
"questionId-comment" => "question comment",
|
|
"answerId" => "answer",
|
|
"answerId-comment" => "answer comment",
|
|
}
|
|
|
|
See L<"questionId"> and L<"answerId">.
|
|
|
|
=head3 Terminal processing
|
|
|
|
Terminal processing for a section and its questions and answers are handled in
|
|
order. The terminalUrl setting in a question overrides the terminalUrl setting
|
|
for its section. Similarly, with questions and answers, the last terminalUrl
|
|
setting of the set of questions is what is returned for the page, with the questions
|
|
and answers being answered in L<"surveyOrder">.
|
|
|
|
=head3 Branch processing
|
|
|
|
gotos and gotoExpressions are handled similarly as with terminalUrls. The last goto or
|
|
gotoExpression in the set of questions wins.
|
|
|
|
=cut
|
|
|
|
sub recordResponses {
|
|
my $self = shift;
|
|
my ($submittedResponses) = validate_pos( @_, { type => HASHREF } );
|
|
|
|
# Build a lookup table of non-multiple choice question types
|
|
my %knownTypes = map {$_ => 1} @{$self->survey->specialQuestionTypes};
|
|
|
|
# We want to record responses against the "next" response section and questions, since these are
|
|
# the items that have just been displayed to the user.
|
|
my $section = $self->nextResponseSection();
|
|
my @questions = $self->nextQuestions();
|
|
|
|
#GOTO jumps in the Survey. Order of precedence is Answer, Question, then Section.
|
|
my ($goto, $gotoExpression);
|
|
|
|
# Handle terminal Section..
|
|
my $terminalUrl;
|
|
my $sTerminal = 0;
|
|
if ( $section->{terminal} ) {
|
|
$sTerminal = 1;
|
|
$terminalUrl = $section->{terminalUrl};
|
|
}
|
|
# ..and also gotos..
|
|
elsif ( $section->{goto} =~ /\w/ ) {
|
|
$goto = $section->{goto};
|
|
}
|
|
# .. and also gotoExpressions..
|
|
elsif ( $section->{gotoExpression} =~ /\w/ ) {
|
|
$gotoExpression = $section->{gotoExpression};
|
|
}
|
|
|
|
# Handle empty Section..
|
|
if ( !@questions ) {
|
|
# No questions to process, so increment lastResponse and return
|
|
$self->lastResponse( $self->nextResponse );
|
|
return [ $sTerminal, $terminalUrl ];
|
|
}
|
|
|
|
# Process Questions in Section..
|
|
my $terminal = 0;
|
|
my $allRequiredQsAnswered = 1;
|
|
for my $question (@questions) {
|
|
my $aAnswered = 0;
|
|
|
|
# Handle terminal Questions..
|
|
if ( $question->{terminal} ) {
|
|
$terminal = 1;
|
|
$terminalUrl = $question->{terminalUrl};
|
|
}
|
|
# ..and also gotos..
|
|
elsif ( $question->{goto} =~ /\w/ ) {
|
|
$goto = $question->{goto};
|
|
}
|
|
# .. and also gotoExpressions..
|
|
elsif ( $question->{gotoExpression} =~ /\w/ ) {
|
|
$gotoExpression = $question->{gotoExpression};
|
|
}
|
|
|
|
# Record Question comment
|
|
$self->responses->{ $question->{id} }->{comment} = $submittedResponses->{ $question->{id} . 'comment' };
|
|
|
|
# Process Answers in Question..
|
|
for my $answer ( @{ $question->{answers} } ) {
|
|
|
|
# Pluck the values out of the responses hash that we want to record..
|
|
my $submittedAnswerResponse = $submittedResponses->{ $answer->{id} };
|
|
my $submittedAnswerComment = $submittedResponses->{ $answer->{id} . 'comment' };
|
|
my $submittedAnswerVerbatim = $submittedResponses->{ $answer->{id} . 'verbatim' };
|
|
|
|
# Proceed if we're satisfied that the submitted answer response is valid..
|
|
if ( defined $submittedAnswerResponse && $submittedAnswerResponse =~ /\S/ ) {
|
|
|
|
#Validate answers met question criteria
|
|
if($question->{questionType} eq 'Number'){
|
|
if($answer->{max} =~ /\d/ and $submittedAnswerResponse > $answer->{max}){
|
|
next;
|
|
}elsif($answer->{min} =~ /\d/ and $submittedAnswerResponse < $answer->{min}){
|
|
next;
|
|
}elsif($answer->{step} =~ /\d/ and $submittedAnswerResponse % $answer->{step} != 0){
|
|
next;
|
|
}
|
|
}
|
|
|
|
$aAnswered = 1;
|
|
|
|
# Now, decide what to record. For multi-choice questions, use recordedAnswer.
|
|
# Otherwise, we use the (raw) submitted response (e.g. text input, date input etc..)
|
|
$self->responses->{ $answer->{id} }->{value}
|
|
= $knownTypes{ $question->{questionType} }
|
|
? $submittedAnswerResponse
|
|
: $answer->{recordedAnswer};
|
|
|
|
$self->responses->{ $answer->{id} }->{verbatim} = $answer->{verbatim} ? $submittedAnswerVerbatim : undef;
|
|
$self->responses->{ $answer->{id} }->{time} = time;
|
|
$self->responses->{ $answer->{id} }->{comment} = $submittedAnswerComment;
|
|
|
|
# Handle terminal Answers..
|
|
if ( $answer->{terminal} ) {
|
|
$terminal = 1;
|
|
$terminalUrl = $answer->{terminalUrl};
|
|
}
|
|
|
|
# ..and also gotos..
|
|
elsif ( $answer->{goto} =~ /\w/ ) {
|
|
$goto = $answer->{goto};
|
|
}
|
|
|
|
# .. and also gotoExpressions..
|
|
elsif ( $answer->{gotoExpression} =~ /\w/ ) {
|
|
$gotoExpression = $answer->{gotoExpression};
|
|
}
|
|
}
|
|
}
|
|
|
|
# Check if a required Question was skipped
|
|
if ( $question->{required} && !$aAnswered ) {
|
|
$allRequiredQsAnswered = 0;
|
|
}
|
|
|
|
# If question was answered, increment the questionsAnswered count..
|
|
if ($aAnswered) {
|
|
$self->questionsAnswered(+1);
|
|
}
|
|
}
|
|
|
|
# If all required responses were given, proceed onwards!
|
|
if ($allRequiredQsAnswered) {
|
|
|
|
# Move the lastResponse index to the last question answered
|
|
$self->lastResponse( $self->lastResponse + @questions );
|
|
|
|
# Do any requested branching..
|
|
$self->processGoto($goto) if ( defined $goto ); ## no critic
|
|
$self->processGotoExpression($gotoExpression) if ( defined $gotoExpression ); ## no critic
|
|
}
|
|
else {
|
|
# Required responses were missing, so we don't let the Survey terminate
|
|
$terminal = 0;
|
|
}
|
|
|
|
if ( $sTerminal && $self->nextResponseSectionIndex != $self->lastResponseSectionIndex ) {
|
|
$terminal = 1;
|
|
}
|
|
|
|
return [ $terminal, $terminalUrl ];
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 processGoto ( $variable )
|
|
|
|
Looks through all sections and questions for their variable key, in order. If the requested
|
|
$variable matches a variable, then the lastResponse is set so that that section or question
|
|
is the next displayed. If more than one variable name matches, then the first is used.
|
|
|
|
=head3 $variable
|
|
|
|
A variable name to match against all section and question variable names.
|
|
|
|
=cut
|
|
|
|
sub processGoto {
|
|
my $self = shift;
|
|
my ($goto) = validate_pos(@_, {type => SCALAR});
|
|
|
|
if ($goto eq 'NEXT_SECTION') {
|
|
$self->session->log->debug("NEXT_SECTION jump target encountered");
|
|
my $lastResponseSectionIndex = $self->lastResponseSectionIndex;
|
|
|
|
# Increment lastRepsonse until nextResponseSectionIndex moves
|
|
while ($self->nextResponseSectionIndex == $lastResponseSectionIndex) {
|
|
$self->lastResponse( $self->lastResponse + 1);
|
|
}
|
|
return;
|
|
}
|
|
|
|
if ($goto eq 'END_SURVEY') {
|
|
$self->session->log->debug("END_SURVEY jump target encountered");
|
|
$self->lastResponse( scalar( @{ $self->surveyOrder} ) - 1 );
|
|
return;
|
|
}
|
|
|
|
# Iterate over items in order..
|
|
my $itemIndex = 0;
|
|
for my $address (@{ $self->surveyOrder }) {
|
|
|
|
# Retreive the section and question for this address..
|
|
my $section = $self->survey->section( $address );
|
|
my $question = $self->survey->question( $address );
|
|
|
|
# See if our goto variable matches the section variable..
|
|
if ( ref $section eq 'HASH' && $section->{variable} eq $goto ) {
|
|
|
|
# Fudge lastResponse so that the next response item will be our matching item
|
|
$self->lastResponse( $itemIndex - 1 );
|
|
last;
|
|
}
|
|
|
|
# See if our goto variable matches the question variable..
|
|
if ( ref $question eq 'HASH' && $question->{variable} eq $goto ) {
|
|
|
|
# Fudge lastResponse so that the next response item will be our matching item
|
|
$self->lastResponse( $itemIndex - 1 );
|
|
last;
|
|
}
|
|
|
|
# Increment the item index counter
|
|
$itemIndex++;
|
|
}
|
|
return;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 processGotoExpression ( $gotoExpression )
|
|
|
|
Processes the given gotoExpression, and triggers a call to L<"processGoto"> if the expression
|
|
indicates that we should branch.
|
|
|
|
=head3 $gotoExpression
|
|
|
|
The gotoExpression. See L<WebGUI::Asset::Wobject::Survey::ExpressionEngine> for more info.
|
|
|
|
=cut
|
|
|
|
sub processGotoExpression {
|
|
my $self = shift;
|
|
my ($expression) = validate_pos(@_, {type => SCALAR});
|
|
|
|
# Prepare the ingredients..
|
|
my $values = $self->responseValuesByVariableName;
|
|
my $scores = $self->responseScoresByVariableName;
|
|
my %validTargets = map { $_ => 1 } @{$self->survey->getGotoTargets};
|
|
|
|
use WebGUI::Asset::Wobject::Survey::ExpressionEngine;
|
|
my $engine = "WebGUI::Asset::Wobject::Survey::ExpressionEngine";
|
|
if (my $jump = $engine->run($self->session, $expression, { values => $values, scores => $scores, validTargets => \%validTargets} )) {
|
|
$self->session->log->debug("Hit. Jumping to [$jump]");
|
|
$self->processGoto($jump);
|
|
}
|
|
$self->session->log->debug("No hits, falling through");
|
|
return;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 recordedResponses
|
|
|
|
Returns an array or response information in this response's survey order.
|
|
|
|
=cut
|
|
|
|
sub recordedResponses{
|
|
my $self = shift;
|
|
my $responses= [
|
|
# {answer info hash}
|
|
];
|
|
# Populate @$responses with the user's data..
|
|
for my $address ( @{ $self->surveyOrder } ) {
|
|
my $question = $self->survey->question( $address );
|
|
my ($sIndex, $qIndex) = (sIndex($address), qIndex($address));
|
|
for my $aIndex (aIndexes($address)) {
|
|
my $question = $self->survey->question([$sIndex,$qIndex]);
|
|
my $answerId = $self->answerId($sIndex, $qIndex, $aIndex);
|
|
if ( defined $self->responses->{$answerId} ) {
|
|
my $answer = $self->survey->answer( [ $sIndex, $qIndex, $aIndex ] );
|
|
push(@$responses, {
|
|
value => $answer->{value} =~ /\w/ ? $answer->{value} : $question->{value},
|
|
recordedAnswer => $answer->{recordedAnswer},
|
|
isCorrect => $answer->{isCorrect},
|
|
answerText => $answer->{text},
|
|
address => [$sIndex,$qIndex,$aIndex],
|
|
questionText => $question->{text},
|
|
questionValue => $question->{value},
|
|
questionType => $question->{questionType}
|
|
}
|
|
);
|
|
}
|
|
}
|
|
}
|
|
return $responses;
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 responseValuesByVariableName ( $options )
|
|
|
|
Returns a lookup table to question variable names and recorded response values.
|
|
|
|
Only questions with a defined variable name set are included. Values come from
|
|
the L<responses> hash.
|
|
|
|
=head3 options
|
|
|
|
The following options are supported:
|
|
|
|
=over 3
|
|
|
|
=item * useText
|
|
|
|
For multiple choice questions, use the answer text instead of the recorded value
|
|
(useful for doing [[var]] text substitution
|
|
|
|
=back
|
|
|
|
=cut
|
|
|
|
sub responseValuesByVariableName {
|
|
my $self = shift;
|
|
my %options = validate(@_, { useText => 0 });
|
|
|
|
my %lookup;
|
|
while (my ($address, $response) = each %{$self->responses}) {
|
|
next if (!$response || !$address);
|
|
|
|
# Turn responses s-q-a string into an address array
|
|
my @address = split /-/, $address;
|
|
|
|
# Filter out the non-answer entries
|
|
next unless @address == 3;
|
|
|
|
# Grab the corresponding question
|
|
my $question = $self->survey->question([@address]);
|
|
|
|
# Filter out questions without defined variable names
|
|
next if !$question || !defined $question->{variable};
|
|
|
|
my $value = $response->{value};
|
|
if ($options{useText}) {
|
|
# Test if question is a multiple choice type so we can use the answer text instead
|
|
if($self->survey->getMultiChoiceBundle($question->{questionType})){
|
|
my $answer = $self->survey->answer([@address]);
|
|
my $answerText = $answer->{text};
|
|
|
|
# For verbatim mc answers, combine answer text and recorded value
|
|
if ($answer->{verbatim}) {
|
|
$answerText = "$answerText - \"$response->{verbatim}\"";
|
|
}
|
|
$value = $answerText ? $answerText : $value;
|
|
}
|
|
}
|
|
|
|
# Add variable => value to our hash
|
|
$lookup{$question->{variable}} = $value;
|
|
}
|
|
return \%lookup;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 responseScoresByVariableName
|
|
|
|
Returns a lookup table to question variable names and recorded response values.
|
|
|
|
Only questions with a defined variable name set are included. Scores come from
|
|
the L<responses> hash.
|
|
|
|
=cut
|
|
|
|
sub responseScoresByVariableName {
|
|
my $self = shift;
|
|
|
|
my %lookup;
|
|
while (my ($address, $response) = each %{$self->responses}) {
|
|
next if (!$response || !$address);
|
|
|
|
# Turn responses s-q-a string into an address array
|
|
my @address = split /-/, $address;
|
|
|
|
# Filter out the non-answer entries
|
|
next unless @address == 3;
|
|
|
|
# Grab the corresponding question
|
|
my $question = $self->survey->question([@address]);
|
|
|
|
# Filter out questions without defined variable names
|
|
next if !$question || !defined $question->{variable};
|
|
|
|
# Grab the corresponding answer
|
|
my $answer = $self->survey->answer([@address]);
|
|
|
|
# Use question score if answer score undefined
|
|
my $score = (exists $answer->{value} && length $answer->{value} > 0) ? $answer->{value} : $question->{value};
|
|
|
|
# Add variable => score to our hash
|
|
$lookup{$question->{variable}} = $score;
|
|
}
|
|
|
|
# Add section score totals
|
|
for my $s (@{$self->survey->sections}) {
|
|
next unless $s->{variable};
|
|
|
|
my $score = 0;
|
|
for my $q (@{$s->{questions}}) {
|
|
next unless $q->{variable};
|
|
next unless exists $lookup{$q->{variable}};
|
|
|
|
$lookup{$s->{variable}} += $lookup{$q->{variable}};
|
|
}
|
|
}
|
|
|
|
return \%lookup;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 getTemplatedText ($text, $responses)
|
|
|
|
Scans a string of text for instances of "[[var]]". Looks up each match in the given hash reference
|
|
and replaces the string with the associated hash value.
|
|
|
|
This method is used to enable simple templating in Survey Section/Question/Answer text. $responses will
|
|
usually be a hash of all of the users responses so that their previous responses can be displayed in
|
|
the text of later questions.
|
|
|
|
=head3 text
|
|
|
|
A string of text. e.g.
|
|
|
|
Your chose the value [[Q2]] in Question 2
|
|
|
|
=head3 params
|
|
|
|
A hash reference. Each matching key in the string will be replaced with its associated value.
|
|
|
|
=cut
|
|
|
|
sub getTemplatedText {
|
|
my $self = shift;
|
|
my ($text, $params) = validate_pos(@_, { type => SCALAR }, { type => HASHREF });
|
|
|
|
# Replace all instances of [[var]] with the value from the $params hash reference
|
|
$text =~ s/\[\[([^\%]*?)\]\]/$params->{$1}/eg;
|
|
|
|
return $text;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 nextQuestions
|
|
|
|
Returns a list (array ref) of the Questions that should be shwon on the next page of the Survey.
|
|
Each Question also contains a list (array ref) of associated Answers.
|
|
|
|
N.B. These are safe copies of the Survey data.
|
|
|
|
The number of questions is determined by the questionsPerPage property of the 'next' section
|
|
in L<"surveyOrder">.
|
|
|
|
Each element of the array ref returned is a question data structure (see
|
|
L<WebGUI::Asset::Wobject::Survey::SurveyJSON>), with some additional fields:
|
|
|
|
=over 4
|
|
|
|
=item sid Section Id field (see L<"sectionId">)
|
|
|
|
=item id Question id (see L<"questionId">.
|
|
|
|
=item answers An array of Answers (see L<WebGUI::Asset::Wobject::Survey::SurveyJSON>), with
|
|
each answer in the array containing an Answer Id (see L<"answerId">)
|
|
|
|
=back
|
|
|
|
Survey, Question and Answer template text is processed here (see L<"getTemplatedText">)
|
|
|
|
=cut
|
|
|
|
sub nextQuestions {
|
|
my $self = shift;
|
|
|
|
# See if we've reached the end of the Survey
|
|
return if $self->surveyEnd;
|
|
|
|
# Get some information about the Section that the next response belongs to..
|
|
my $section = $self->nextResponseSection();
|
|
my $sectionIndex = $self->nextResponseSectionIndex;
|
|
my $questionsPerPage = $self->survey->section( [ $self->nextResponseSectionIndex ] )->{questionsPerPage};
|
|
|
|
# Get all of the existing question responses (so that we can do Section and Question [[var]] replacements
|
|
my $responseValuesByVariableName = $self->responseValuesByVariableName( { useText => 1 } );
|
|
|
|
# Do text replacement
|
|
$section->{text} = $self->getTemplatedText($section->{text}, $responseValuesByVariableName);
|
|
|
|
# Collect all the questions to be shown on the next page..
|
|
my @questions;
|
|
for my $i (1 .. $questionsPerPage ) {
|
|
my $address = $self->surveyOrder->[ $self->lastResponse + $i ];
|
|
last if(! defined $address);
|
|
my ($sIndex, $qIndex) = (sIndex($address), qIndex($address));
|
|
|
|
# Skip if this is a Section without a Question
|
|
if ( !defined $qIndex ) {
|
|
next;
|
|
}
|
|
|
|
# Stop if we have left the Section
|
|
if ( $sIndex != $sectionIndex ) {
|
|
last;
|
|
}
|
|
|
|
# Make a safe copy of the question
|
|
my %questionCopy = %{$self->survey->question( $address )};
|
|
|
|
# Do text replacement
|
|
$questionCopy{text} = $self->getTemplatedText($questionCopy{text}, $responseValuesByVariableName);
|
|
|
|
# Add any extra fields we want..
|
|
$questionCopy{id} = $self->questionId($sIndex, $qIndex);
|
|
$questionCopy{sid} = $self->sectionId($sIndex);
|
|
|
|
# Rebuild the list of anwers with a safe copy
|
|
delete $questionCopy{answers};
|
|
for my $aIndex ( aIndexes($address) ) {
|
|
my %answerCopy = %{ $self->survey->answer( [ $sIndex, $qIndex, $aIndex ] ) };
|
|
|
|
# Do text replacement
|
|
$answerCopy{text} = $self->getTemplatedText($answerCopy{text}, $responseValuesByVariableName);
|
|
|
|
# Add any extra fields we want..
|
|
$answerCopy{id} = $self->answerId($sIndex, $qIndex, $aIndex);
|
|
|
|
push @{ $questionCopy{answers} }, \%answerCopy;
|
|
}
|
|
push @questions, \%questionCopy;
|
|
}
|
|
return @questions;
|
|
}
|
|
|
|
=head2 sectionId
|
|
|
|
Convenience method to construct a Section Id from the given Section index.
|
|
|
|
A Section Id is identical to a Section index. This method is only present for consistency with questionId and answerId.
|
|
|
|
=cut
|
|
|
|
sub sectionId {
|
|
my $self = shift;
|
|
my ($sIndex) = validate_pos(@_, { type => SCALAR | UNDEF } );
|
|
|
|
return if !defined $sIndex;
|
|
|
|
return $sIndex;
|
|
}
|
|
|
|
=head2 questionId
|
|
|
|
Convenience method to construct a Question Id from the given Section index and Question index.
|
|
|
|
The id is constructed by hyphenating the Section index and Question index.
|
|
|
|
=cut
|
|
|
|
sub questionId {
|
|
my $self = shift;
|
|
my ($sIndex, $qIndex) = validate_pos(@_, { type => SCALAR | UNDEF }, { type => SCALAR | UNDEF } );
|
|
|
|
return if !defined $sIndex || !defined $qIndex;
|
|
|
|
return "$sIndex-$qIndex";
|
|
}
|
|
|
|
=head2 answerId
|
|
|
|
Convenience method to construct an Answer Id from the given Section index, Question index and Answer index.
|
|
|
|
The id is constructed by hyphenating all three indices.
|
|
|
|
=cut
|
|
|
|
sub answerId {
|
|
my $self = shift;
|
|
my ($sIndex, $qIndex, $aIndex) = validate_pos(@_, { type => SCALAR | UNDEF }, { type => SCALAR | UNDEF }, { type => SCALAR | UNDEF } );
|
|
|
|
return if !defined $sIndex || !defined $qIndex || !defined $aIndex;
|
|
|
|
return "$sIndex-$qIndex-$aIndex";
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 surveyEnd
|
|
|
|
Returns true if the current index stored in lastResponse is greater than or
|
|
equal to the number of sections in the survey order.
|
|
|
|
=cut
|
|
|
|
sub surveyEnd {
|
|
my $self = shift;
|
|
|
|
return 1 if ( $self->lastResponse >= $#{ $self->surveyOrder } );
|
|
return 0;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 sIndex ($address)
|
|
|
|
Convenience sub to extract the section index from an address in the L<"surveyOrder"> array.
|
|
This method exists purely to improve code readability.
|
|
This method is identical to L<WebGUI::Asset::Wobject::Survey::SurveyJSON/sIndex>.
|
|
|
|
=cut
|
|
|
|
sub sIndex {
|
|
my ($address) = validate_pos(@_, { type => ARRAYREF});
|
|
return $address->[0];
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 qIndex ($address)
|
|
|
|
Convenience sub to extract the question index from an address in the L<"surveyOrder"> array.
|
|
This method exists purely to improve code readability.
|
|
This method is identical to L<WebGUI::Asset::Wobject::Survey::SurveyJSON/qIndex>.
|
|
|
|
=cut
|
|
|
|
sub qIndex {
|
|
my ($address) = validate_pos(@_, { type => ARRAYREF});
|
|
return $address->[1];
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 aIndexes ($address)
|
|
|
|
Convenience sub to extract the array of answer indices from an address in the L<"surveyOrder"> array.
|
|
This method exists purely to improve code readability.
|
|
Unlike sIndex and qIndex, this method is different to L<WebGUI::Asset::Wobject::Survey::SurveyJSON/aIndex>.
|
|
This is because the third element of the L<"surveyOrder"> address array ref in is an array of answer indices.
|
|
|
|
=cut
|
|
|
|
sub aIndexes {
|
|
my ($address) = validate_pos(@_, { type => ARRAYREF});
|
|
|
|
if (my $indexes = $address->[2]) {
|
|
return @{ $indexes };
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 showSummary ( [$sectionAddresses] )
|
|
|
|
showSummary returns the current responses summary for the entire response, if
|
|
no address is passed in, or just the sections addressed by $sectionAddresses.
|
|
|
|
For each section, the total correct, wrong, time taken, and points are returned. And each
|
|
question is listed with the text, given score, user response, and if it was correct.
|
|
This list is meant for a template and only what is needed should be shown.
|
|
|
|
A summary of the entire suvey,
|
|
|
|
=cut
|
|
|
|
sub showSummary{
|
|
my $self = shift;
|
|
my $sectionAddies = shift;#array of section addresses
|
|
|
|
my $all = 0;
|
|
$all = 1 if(! $sectionAddies);
|
|
|
|
my ($summaries);
|
|
|
|
my $responses = $self->recordedResponses();
|
|
my %goodSection;
|
|
map{$goodSection{$_} = 1} @$sectionAddies;
|
|
|
|
return if(! $responses);
|
|
|
|
my ($sectionIndex, $responseIndex) = (-1, 1);
|
|
my ($currentSection,$currentQuestion) = (-1,-1);
|
|
($summaries->{totalCorrect},$summaries->{totalIncorrect}) = (0,0);
|
|
|
|
for my $response (@$responses){
|
|
if(! $all and ! $goodSection{$response->{address}->[0]}){next;}
|
|
if($response->{isCorrect}){
|
|
$summaries->{totalCorrect}++;
|
|
}else{
|
|
$summaries->{totalIncorrect}++;
|
|
}
|
|
$summaries->{totalAnswers}++;
|
|
if($currentSection != $response->{address}->[0]){
|
|
$summaries->{totalSections}++;
|
|
$sectionIndex++;
|
|
$responseIndex = -1;
|
|
$currentSection = $response->{address}->[0];
|
|
}
|
|
if($currentQuestion != $response->{address}->[1]){
|
|
$summaries->{totalQuestions}++;
|
|
}
|
|
_loadSectionIntoSummary(\%{$summaries->{sections}->[$sectionIndex]}, $response);
|
|
$responseIndex++;
|
|
_loadResponseIntoSummary(\%{$summaries->{sections}->[$sectionIndex]->{responses}->[$responseIndex]},
|
|
$response,
|
|
$self->survey->{multipleChoiceTypes});
|
|
}
|
|
return $summaries;
|
|
}
|
|
sub _loadResponseIntoSummary{
|
|
my $node = shift;
|
|
my $response = shift;
|
|
my $types = shift;
|
|
|
|
$node->{"Question ID"} = $response->{address}->[1] + 1;
|
|
$node->{"Question Text"} = $response->{questionText};
|
|
$node->{"Answer ID"} = $response->{address}->[2] + 1;
|
|
if($response->{isCorrect}){
|
|
$node->{Correct} = "Y";
|
|
$node->{Score} = $response->{value};
|
|
}else{
|
|
$node->{Correct} = "N";
|
|
$node->{Score} = 0;
|
|
}
|
|
$node->{"Answer Text"} = $response->{answerText};
|
|
|
|
#test if it is a multiple choide type
|
|
if($types->{$response->{questionType}}){
|
|
$node->{Value} = $response->{value};
|
|
}else{
|
|
$node->{Value} = $response->{recordedValue};
|
|
}
|
|
}
|
|
sub _loadSectionIntoSummary{
|
|
my $node = shift;
|
|
my $response = shift;
|
|
$node->{id} = $response->{address}->[0] + 1;
|
|
$node->{inCorrect} = 0 if(!defined $node->{inCorrect});
|
|
$node->{score} = 0 if(!defined $node->{score});
|
|
$node->{correct} = 0 if(!defined $node->{correct});
|
|
$node->{total} = 0 if(!defined $node->{total});
|
|
$node->{total}++;
|
|
if($response->{isCorrect} == 1){
|
|
$node->{score} += $response->{value};
|
|
$node->{correct}++;
|
|
}else{
|
|
$node->{inCorrect}++;
|
|
}
|
|
|
|
}
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 returnResponseForReporting
|
|
|
|
Used to extract JSON responses for use in reporting results.
|
|
|
|
Returns an array ref containing the current responses to the survey. The array ref contains a list of hashes with the section, question,
|
|
sectionName, questionName, questionComment, and an answer array ref. The answer array ref contains a list of hashes, with isCorrect (1 true, 0 false),
|
|
recorded value, and the id of the answer.
|
|
|
|
=cut
|
|
|
|
# TODO: This sub should make use of responseValuesByVariableName
|
|
|
|
sub returnResponseForReporting {
|
|
my $self = shift;
|
|
my @report = ();
|
|
for my $address ( @{ $self->surveyOrder } ) {
|
|
my ($sIndex, $qIndex) = (sIndex($address), qIndex($address));
|
|
my $section = $self->survey->section( $address );
|
|
my $question = $self->survey->question( [ $sIndex, $qIndex ] );
|
|
my $questionId = $self->questionId($sIndex, $qIndex);
|
|
|
|
# Skip if this is a Section without a Question
|
|
if ( !defined $qIndex ) {
|
|
next;
|
|
}
|
|
|
|
my @responses;
|
|
for my $aIndex (aIndexes($address)) {
|
|
my $answerId = $self->answerId($sIndex, $qIndex, $aIndex);
|
|
|
|
if ( $self->responses->{$answerId} ) {
|
|
|
|
# Make a safe copy of the response
|
|
my %response = %{$self->responses->{$answerId}};
|
|
$response{id} = $aIndex;
|
|
|
|
my $answer = $self->survey->answer( [ $sIndex, $qIndex, $aIndex ] );
|
|
if ( $answer->{isCorrect} ) {
|
|
$response{value}
|
|
= $answer->{value} =~ /\w/ ? $answer->{value}
|
|
: $question->{value}
|
|
;
|
|
$response{isCorrect} = 1;
|
|
}
|
|
else {
|
|
$response{isCorrect} = 0;
|
|
}
|
|
push @responses, \%response;
|
|
}
|
|
}
|
|
push @report, {
|
|
section => $sIndex,
|
|
question => $qIndex,
|
|
sectionName => $section->{variable},
|
|
questionName => $question->{variable},
|
|
questionComment => $self->responses->{$questionId}->{comment},
|
|
answers => \@responses
|
|
};
|
|
}
|
|
return \@report;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 response
|
|
|
|
Accessor for the Perl hash containing Response data
|
|
|
|
=cut
|
|
|
|
sub response {
|
|
my $self = shift;
|
|
return $self->{_response};
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 responses
|
|
|
|
Mutator. Note, this is an unsafe reference.
|
|
|
|
This data structure stores a snapshot of all question responses. Both question data and answer data
|
|
is stored in this hash reference.
|
|
|
|
Questions keys are constructed by hypenating the relevant L<"sIndex"> and L<"qIndex">.
|
|
Answer keys are constructed by hypenating the relevant L<"sIndex">, L<"qIndex"> and L<aIndex|"aIndexes">.
|
|
|
|
{
|
|
# Question entries only contain a comment field, e.g.
|
|
'0-0' => {
|
|
comment => "question comment",
|
|
},
|
|
# ...
|
|
# Answers entries contain: value (the recorded value), time and comment fields.
|
|
'0-0-0' => {
|
|
value => "recorded answer value",
|
|
time => time(),
|
|
comment => "answer comment",
|
|
},
|
|
# ...
|
|
}
|
|
|
|
=cut
|
|
|
|
sub responses {
|
|
my $self = shift;
|
|
my $responses = shift;
|
|
if ( defined $responses ) {
|
|
$self->response->{responses} = $responses;
|
|
}
|
|
return $self->response->{responses};
|
|
}
|
|
|
|
=head2 pop
|
|
|
|
=cut
|
|
|
|
sub pop {
|
|
my $self = shift;
|
|
my %responses = %{ $self->responses };
|
|
|
|
# Iterate over responses first time to determine time of most recent response(s)
|
|
my $lastResponseTime;
|
|
for my $r ( values %responses ) {
|
|
if ( $r->{time} ) {
|
|
$lastResponseTime
|
|
= !$lastResponseTime || $r->{time} > $lastResponseTime
|
|
? $r->{time}
|
|
: $lastResponseTime
|
|
;
|
|
}
|
|
}
|
|
|
|
return unless $lastResponseTime;
|
|
|
|
my $popped;
|
|
my $poppedQuestions;
|
|
# Iterate again, removing most recent responses
|
|
while (my ($address, $r) = each %responses ) {
|
|
if ( $r->{time} == $lastResponseTime) {
|
|
$popped->{$address} = $r;
|
|
delete $self->responses->{$address};
|
|
|
|
# Remove associated question/comment entry
|
|
my ($sIndex, $qIndex, $aIndex) = split /-/, $address;
|
|
my $qAddress = "$sIndex-$qIndex";
|
|
$popped->{$qAddress} = $responses{$qAddress};
|
|
delete $self->responses->{$qAddress};
|
|
|
|
# while we're here, build lookup table of popped question ids
|
|
$poppedQuestions->{$qAddress} = 1;
|
|
}
|
|
}
|
|
|
|
# Now, nextResponse should be set to index of the first popped question we can find in surveyOrder
|
|
my $nextResponse = 0;
|
|
for my $address (@{ $self->surveyOrder }) {
|
|
my $questionId = "$address->[0]-$address->[1]";
|
|
if ($poppedQuestions->{$questionId} ) {
|
|
$self->session->log->debug("setting nextResponse to $nextResponse");
|
|
$self->nextResponse($nextResponse);
|
|
last;
|
|
}
|
|
$nextResponse++;
|
|
}
|
|
|
|
return $popped;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 survey
|
|
|
|
Returns a referece to the SurveyJSON object that this object was created with.
|
|
|
|
Note, this is an unsafe reference.
|
|
|
|
=cut
|
|
|
|
sub survey {
|
|
my $self = shift;
|
|
return $self->{_survey};
|
|
}
|
|
|
|
1;
|