821635eb71
Added Params::Validate to ResponseJSON.pm Refactored ResponseJSON constructor and re-ordered params for consistency Added new ->session accessor Updates tests Removed unnecessary logging methods Further refactored SurveyJSON, gave private variables underscores, replaced direct hash access with accessors
864 lines
27 KiB
Perl
864 lines
27 KiB
Perl
package WebGUI::Asset::Wobject::Survey::ResponseJSON;
|
|
|
|
=head1 LEGAL
|
|
|
|
-------------------------------------------------------------------
|
|
WebGUI is Copyright 2001-2008 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. It manages data
|
|
from the user, sets the order of questions and answers in the survey,
|
|
based on branches, and gotos, and also handles expiring the survey
|
|
due to time limits.
|
|
|
|
This package is not intended to be used by any other Asset in WebGUI.
|
|
|
|
=cut
|
|
|
|
use strict;
|
|
use JSON;
|
|
use Params::Validate qw(:all);
|
|
Params::Validate::validation_options( on_fail => sub { WebGUI::Error::InvalidParam->throw( error => shift ) } );
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 new ( $survey, $json )
|
|
|
|
Object constructor.
|
|
|
|
=head3 $survey
|
|
|
|
A 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 "startTime", "surveyOrder", "responses", "lastReponse"
|
|
and "questionsAnswered" keys, with appropriate values.
|
|
|
|
=cut
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
my ($survey, $json) = validate_pos(@_, {isa => 'WebGUI::Asset::Wobject::Survey::SurveyJSON' }, { type => SCALAR, 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,
|
|
|
|
# And now object defaults..
|
|
responses => {},
|
|
lastResponse => -1,
|
|
questionsAnswered => 0,
|
|
startTime => time(),
|
|
surveyOrder => [],
|
|
|
|
# And finally, allow jsonData to override defaults and/or add other members
|
|
%$jsonData,
|
|
};
|
|
|
|
return bless( $self, $class );
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
|
|
=head2 createSurveyOrder ( SurveyJSON, [address,address] )
|
|
|
|
This creates the order for the survey which will change after every fork. The survey
|
|
order is to precreate random questions and answers, which also leaves a record or what
|
|
the user was presented with. Forks are passed in to show where to branch the new order.
|
|
|
|
If questions and/or answers were set to be randomized, it is handled in here.
|
|
|
|
=cut
|
|
|
|
sub createSurveyOrder {
|
|
my $self = shift;
|
|
my $order;
|
|
my $qstarting = 0;
|
|
for ( my $s = 0; $s <= $#{ $self->survey->sections() }; $s++ ) {
|
|
|
|
#create question order for section
|
|
my @qorder;
|
|
if ( $self->survey->section( [$s] )->{randomizeQuestions} ) {
|
|
@qorder = shuffle( ( $qstarting .. $#{ $self->survey->questions( [$s] ) } ) );
|
|
}
|
|
else {
|
|
@qorder = ( ( $qstarting .. $#{ $self->survey->questions( [$s] ) } ) );
|
|
}
|
|
|
|
#if this is an empty section, make sure it is still on the list to be seen
|
|
if ( @qorder == 0 ) {
|
|
push( @$order, [$s] );
|
|
}
|
|
$qstarting = 0;
|
|
|
|
#create answer order for question
|
|
for (@qorder) {
|
|
my @aorder;
|
|
if ( $self->survey->question( [ $s, $_ ] )->{randomizeAnswers} ) {
|
|
@aorder = shuffle( ( $qstarting .. $#{ $self->survey->question( [ $s, $_ ] )->{answers} } ) );
|
|
}
|
|
else {
|
|
@aorder = ( ( $qstarting .. $#{ $self->survey->question( [ $s, $_ ] )->{answers} } ) );
|
|
}
|
|
push( @$order, [ $s, $_, \@aorder ] );
|
|
}
|
|
} ## end for ( my $s = 0; $s <= ...
|
|
$self->{surveyOrder} = $order;
|
|
} ## end sub createSurveyOrder
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 session
|
|
|
|
Accessor method for the local WebGUI::Session reference
|
|
|
|
=cut
|
|
|
|
sub session {
|
|
my $self = shift;
|
|
return $self->{_session};
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 shuffle ( @array )
|
|
|
|
Returns the contents of @array in a random order.
|
|
|
|
=cut
|
|
|
|
sub shuffle {
|
|
my @a = splice @_;
|
|
for my $i ( 0 .. $#a ) {
|
|
my $j = int rand @a;
|
|
@a[ $i, $j ] = @a[ $j, $i ];
|
|
}
|
|
return @a;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 freeze
|
|
|
|
Serializes the object to JSON, after deleting the log and survey objects stored in it.
|
|
|
|
=cut
|
|
|
|
sub freeze {
|
|
my $self = shift;
|
|
my %temp = %{$self};
|
|
delete $temp{_session};
|
|
delete $temp{_survey};
|
|
return to_json( \%temp );
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
#Has the survey timed out?
|
|
|
|
=head2 hasTimedOut ( $limit )
|
|
|
|
Checks to see whether this survey has timed out, based on the internally stored starting
|
|
time, and $limit.
|
|
|
|
=head3 $limit
|
|
|
|
How long the user has to take the survey, in minutes.
|
|
|
|
=cut
|
|
|
|
sub hasTimedOut{
|
|
my $self=shift;
|
|
my $limit = shift;
|
|
return 1 if($self->startTime() + ($limit * 60) < time() and $limit > 0);
|
|
return 0;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
#the index of the last surveyOrder entry shown
|
|
|
|
=head2 lastResponse ([ $responseIndex ])
|
|
|
|
Mutator for the index of the last surveyOrder entry shown. With no arguments,
|
|
returns the lastResponse index.
|
|
|
|
=head3 $responseIndex
|
|
|
|
If defined, sets the lastResponse to $responseIndex.
|
|
|
|
=cut
|
|
|
|
sub lastResponse {
|
|
my $self = shift;
|
|
my $res = shift;
|
|
if ( defined $res ) {
|
|
$self->{lastResponse} = $res;
|
|
}
|
|
else {
|
|
return $self->{lastResponse};
|
|
}
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 questionsAnswered ([ $questionsAnswered ])
|
|
|
|
Mutator for the number of questions answered. With no arguments,
|
|
does a set.
|
|
|
|
=head3 $questionsAnswered.
|
|
|
|
If defined, increments the number of questions by $questionsAnswered
|
|
|
|
=cut
|
|
|
|
sub questionsAnswered {
|
|
my $self = shift;
|
|
my $answered = shift;
|
|
if ( defined $answered ) {
|
|
$self->{questionsAnswered} += $answered;
|
|
}
|
|
else {
|
|
return $self->{questionsAnswered};
|
|
}
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 startTime ([ $newStartTime ])
|
|
|
|
Mutator for the time the user began the survey. With no arguments,
|
|
returns the startTime.
|
|
|
|
=head3 $newStarttime
|
|
|
|
If defined, sets the starting time to $newStartTime.
|
|
|
|
=cut
|
|
|
|
sub startTime {
|
|
my $self = shift;
|
|
my $newTime = shift;
|
|
if ( defined $newTime ) {
|
|
$self->{startTime} = $newTime;
|
|
}
|
|
else {
|
|
return $self->{startTime};
|
|
}
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
#array of addresses in which the survey should be presented
|
|
|
|
=head2 surveyOrder
|
|
|
|
Accessor for the survey order data structure. It is a deep set of arrays, similar in
|
|
structure to a WebGUI::Asset::Wobject::Survey::SurveyJSON address.
|
|
|
|
[ $sectionIndex, $questionIndex, [ $answerIndex1, $answerIndex2, ....]
|
|
|
|
There is one array element for every section and address in the survey.
|
|
|
|
If there are no questions, or no addresses, those array elements will not be present.
|
|
|
|
=cut
|
|
|
|
sub surveyOrder {
|
|
my $self = shift;
|
|
return $self->{surveyOrder};
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 nextSectionId
|
|
|
|
Relative to the surveyOrder and the lastResponse index, get the index of the
|
|
next section. Note, based on the number of questions in an section, this can
|
|
be the same as the current section index.
|
|
|
|
=cut
|
|
|
|
sub nextSectionId {
|
|
my $self = shift;
|
|
return undef if $self->surveyEnd();
|
|
return $self->surveyOrder->[ $self->lastResponse + 1 ]->[0];
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 nextSection
|
|
|
|
Relative to the surveyOrder and the lastResponse index, gets the next section.
|
|
Note, based on the number of questions in a section, this can be the same as
|
|
the current section.
|
|
|
|
=cut
|
|
|
|
sub nextSection {
|
|
my $self = shift;
|
|
return {} if $self->surveyEnd();
|
|
return $self->survey->section( [ $self->surveyOrder->[ $self->lastResponse + 1 ]->[0] ] );
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 currentSection
|
|
|
|
Relative to the surveyOrder and the lastResponse index, get the current section.
|
|
|
|
=cut
|
|
|
|
sub currentSection {
|
|
my $self = shift;
|
|
return $self->survey->section( [ $self->surveyOrder->[ $self->lastResponse ]->[0] ] );
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 recordResponses ($session, $responses)
|
|
|
|
Takes survey responses and puts them into the response hash of this object. Does terminal
|
|
handling for sections and questions, and goto processing. Advances the survey page if
|
|
all required questions have been answered.
|
|
|
|
=head3 $session
|
|
|
|
A WebGUI session object
|
|
|
|
=head3 $responses
|
|
|
|
A hash ref of form param data. Each element will look like:
|
|
|
|
{
|
|
"__qid__comment" => "question comment",
|
|
"__aid__" => "answer",
|
|
"__aid__comment" => "answer comment",
|
|
}
|
|
|
|
where __qid__ is a question id, as described in L<nextQuestions>, and __aid__ is an
|
|
answer id, also described there.
|
|
|
|
=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 surveyOrder.
|
|
|
|
=head3 goto processing
|
|
|
|
gotos are handled similarly as with terminalUrls. The last goto in the set of questions
|
|
wins.
|
|
|
|
=head3 responses data structure
|
|
|
|
This method also builds an internal data structure with the users' responses. It
|
|
is set up like this:
|
|
|
|
responses => {
|
|
__qid__ => {
|
|
comment => "question comment",
|
|
},
|
|
__aid__ => {
|
|
time => time(),
|
|
comment => "answer comment",
|
|
value => "answer value",
|
|
},
|
|
}
|
|
|
|
=cut
|
|
|
|
sub recordResponses {
|
|
my $self = shift;
|
|
my $session = shift;
|
|
my $responses = shift;
|
|
|
|
my %mcTypes = (
|
|
'Agree/Disagree', 1, 'Certainty', 1, 'Concern', 1, 'Confidence', 1, 'Education', 1,
|
|
'Effectiveness', 1, 'Gender', 1, 'Ideology', 1, 'Importance', 1, 'Likelihood', 1,
|
|
'Party', 1, 'Multiple Choice', 1, 'Oppose/Support', 1, 'Race', 1, 'Risk', 1,
|
|
'Satisfaction', 1, 'Scale', 1, 'Security', 1, 'Threat', 1, 'True/False', 1,
|
|
'Yes/No', 1
|
|
);
|
|
my %sliderTypes = ( 'Dual Slider - Range', 1, 'Multi Slider - Allocate', 1, 'Slider', 1 );
|
|
my %textTypes = ( 'Currency', 'Email', 1, 'Phone Number', 1, 'Text', 1, 'Text Date', 1 ,'TextArea', 1);
|
|
my %fileTypes = ( 'File Upload', 1 );
|
|
my %dateTypes = ( 'Date', 'Date Range', 1 );
|
|
my %hiddenTypes = ( 'Hidden', 1 );
|
|
|
|
#These were just submitted from the user, so we need to see what and how they were (un)answered.
|
|
my $questions = $self->nextQuestions();
|
|
my $qAnswered = 1;
|
|
my $sterminal = 0;
|
|
my $terminal = 0;
|
|
my $terminalUrl;
|
|
my $goto;
|
|
my $gotoExpression;
|
|
|
|
my $section = $self->nextSection();#which gets the current section for the just submitted questions. IE, current response pointer has not moved forward for these questions
|
|
|
|
if ( $section->{terminal} ) {
|
|
$sterminal = 1;
|
|
$terminalUrl = $section->{terminalUrl};
|
|
}
|
|
|
|
#There were no questions in the section just displayed, so increment the lastResponse by one
|
|
if ( ref $questions ne 'ARRAY' ) {
|
|
$self->lastResponse( $self->lastResponse + 1 );
|
|
return [ $sterminal, $terminalUrl ];
|
|
}
|
|
|
|
for my $question (@$questions) {
|
|
my $aAnswered = 0;
|
|
if ( $question->{terminal} ) {
|
|
$terminal = 1;
|
|
$terminalUrl = $question->{terminalUrl};
|
|
}
|
|
$self->responses->{ $question->{id} }->{comment} = $responses->{ $question->{id} . "comment" };
|
|
for my $answer ( @{ $question->{answers} } ) {
|
|
|
|
if ( defined( $responses->{ $answer->{id} } )
|
|
and $responses->{ $answer->{id} } =~ /\S/ )
|
|
{
|
|
|
|
$aAnswered = 1;
|
|
if ( exists $mcTypes{ $question->{questionType} } ) {
|
|
$self->responses->{ $answer->{id} }->{value} = $answer->{recordedAnswer};
|
|
}
|
|
else {
|
|
$self->responses->{ $answer->{id} }->{value} = $responses->{ $answer->{id} };
|
|
}
|
|
$self->responses->{ $answer->{id} }->{'time'} = time();
|
|
$self->responses->{ $answer->{id} }->{comment} = $responses->{ $answer->{id} . "comment" };
|
|
|
|
if ( $answer->{terminal} ) {
|
|
$terminal = 1;
|
|
$terminalUrl = $answer->{terminalUrl};
|
|
}
|
|
elsif ( $answer->{goto} =~ /\w/ ) {
|
|
$goto = $answer->{goto};
|
|
}
|
|
elsif ( $answer->{gotoExpression} =~ /\w/ ) {
|
|
$gotoExpression = $answer->{gotoExpression};
|
|
}
|
|
} ## end if ( defined( $responses...
|
|
} ## end for my $answer ( @{ $question...
|
|
$qAnswered = 0 if ( !$aAnswered and $question->{required} );
|
|
if ($aAnswered) {
|
|
$self->questionsAnswered( +1 );
|
|
}
|
|
} ## end for my $question (@$questions)
|
|
|
|
#if all responses completed, move the lastResponse index to the last question shown
|
|
if ($qAnswered) {
|
|
$self->lastResponse( $self->lastResponse + @$questions );
|
|
$self->goto($goto) if ( defined $goto );
|
|
$self->gotoExpression($gotoExpression) if ( defined $gotoExpression );
|
|
}
|
|
else {
|
|
$terminal = 0;
|
|
}
|
|
|
|
if($sterminal and $self->nextSection != $self->currentSection){
|
|
$terminal = 1;
|
|
}
|
|
|
|
return [ $terminal, $terminalUrl ];
|
|
} ## end sub recordResponses
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 goto ( $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 section or question matches, then the first is used.
|
|
|
|
=head3 $variable
|
|
|
|
The variable to look for in all sections and questions.
|
|
|
|
=cut
|
|
|
|
sub goto {
|
|
my $self = shift;
|
|
my $goto = shift;
|
|
for ( my $i = 0; $i <= $#{ $self->surveyOrder() }; $i++ ) {
|
|
my $section = $self->survey->section( $self->surveyOrder()->[$i] );
|
|
my $question = $self->survey->question( $self->surveyOrder()->[$i] );
|
|
if ( ref $section eq 'HASH' and $section->{variable} eq $goto ) {
|
|
$self->lastResponse( $i - 1 );
|
|
last;
|
|
}
|
|
if ( ref $question eq 'HASH' and $question->{variable} eq $goto ) {
|
|
$self->lastResponse( $i - 1 );
|
|
last;
|
|
}
|
|
}
|
|
} ## end sub goto
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 gotoExpression ( $gotoExpression )
|
|
|
|
=head3 $gotoExpression
|
|
|
|
The gotoExpression (one expression per line)
|
|
|
|
=head3 Explanation
|
|
|
|
A gotoExpression is a list of expressions (one per line) of the form:
|
|
target: expression
|
|
target: expression
|
|
|
|
This subroutine iterates through the list, processing each line and, all things being
|
|
well, evaluates the expression. The first expression to evaluate to true triggers a
|
|
call to goto($target).
|
|
|
|
The expression is a simple subset of the formula language used in spreadsheet programs such as Excel, OpenOffice, Google Docs etc..
|
|
|
|
Here is an example using section variables S1 and S2 as jump targets and question variables Q1-3 in the expression.
|
|
It jumps to S1 if the user's answer to Q1 has a value of 3, jumps to S2 if Q2 + Q3 < 10, and otherwise doesn't branch at all (the default).
|
|
S1: Q1 = 3
|
|
S2: Q2 + Q3 < 10
|
|
|
|
=head3 Arguments are evaluated as follows:
|
|
|
|
Numeric arguments evaluate as numbers
|
|
* No support for strings (and hence no string matching)
|
|
* Question variable names (e.g. Q1) evaluate to the numeric value associated with user's answer to that question, or undefined if the user has not answered that question
|
|
|
|
Binary comparisons operators: = != < <= >= >
|
|
* return boolean values based on perl's equivalent numeric comparison operators
|
|
|
|
Simple math operators: + - * /
|
|
* return numeric values
|
|
|
|
Later we may add Boolean operators: AND( x; y; z; ... ), OR( x; y; z; ... ), NOT( x )
|
|
* args separated by semicolons (presumably because spreadsheet formulas use commas to indicate cell ranges)
|
|
|
|
Later still you may be able to say AVG(section1) or SUM(section3) and have those functions automatically compute their result over the set of all questions in the given section.
|
|
But for now those things can be done manually using the limited subset defined.
|
|
|
|
=cut
|
|
|
|
sub gotoExpression {
|
|
my $self = shift;
|
|
my $expression = shift;
|
|
|
|
my %responses = (
|
|
# questionName => response answer value
|
|
);
|
|
|
|
# Populate %responses with the user's data..
|
|
foreach my $q (@{ $self->returnResponseForReporting() }) {
|
|
if ($q->{questionName} =~ /\w/) {
|
|
my $value = $q->{answers}[0]{value};
|
|
$responses{$q->{questionName}} = $value if defined $value;
|
|
}
|
|
}
|
|
|
|
# Process gotoExpressions one after the other (first one that's true wins)
|
|
foreach my $line (split '\n', $expression) {
|
|
my $processed = $self->processGotoExpression($line, \%responses);
|
|
|
|
next unless $processed;
|
|
|
|
# (ab)use perl's eval to evaluate the processed expression
|
|
my $result = eval "$processed->{expression}";
|
|
$self->session->log->warn($@) if $@;
|
|
|
|
if ($result) {
|
|
$self->session->log->debug("Truthy, goto [$processed->{target}]");
|
|
$self->goto($processed->{target});
|
|
return $processed;
|
|
} else {
|
|
$self->session->log->debug("Falsy, not branching");
|
|
next;
|
|
}
|
|
}
|
|
return;
|
|
}
|
|
|
|
=head2 processGotoExpression ( $expression, $responses)
|
|
|
|
Parses a single gotoExpression. Returns undef if processing fails, or the following hashref
|
|
if things work out well:
|
|
{ target => $target, expression => $expression }
|
|
|
|
=head3 $expression
|
|
|
|
The expression to process
|
|
|
|
=head3 $responses
|
|
|
|
Hashref that maps questionNames to response values
|
|
|
|
=head3 Explanation:
|
|
|
|
Uses the following simple strategy:
|
|
|
|
First, parse the expression as:
|
|
target: expression
|
|
|
|
Replace each questionName with its response value (from the $responses hashref)
|
|
|
|
Massage the expression into valid perl
|
|
|
|
Check that only valid tokens remain. This last step ensures that any invalid questionNames in
|
|
the expression generate an error because our list of valid tokens doesn't include a-z
|
|
|
|
=cut
|
|
|
|
sub processGotoExpression {
|
|
my $self = shift;
|
|
my $expression = shift;
|
|
my $responses = shift;
|
|
|
|
$self->session->log->debug("Processing gotoExpression: $expression");
|
|
|
|
# Valid gotoExpression tokens are..
|
|
my $tokens = qr{\s|[-0-9=!<>+*/.()]};
|
|
|
|
my ( $target, $rest ) = $expression =~ /\s* ([^:]+?) \s* : \s* (.*)/x;
|
|
|
|
$self->session->log->debug("Parsed as Target: [$target], Expression: [$rest]");
|
|
|
|
if ( !defined $target ) {
|
|
$self->session->log->warn('Target undefined');
|
|
return;
|
|
}
|
|
|
|
if ( !defined $rest || $rest eq '' ) {
|
|
$self->session->log->warn('Expression undefined');
|
|
return;
|
|
}
|
|
|
|
# Replace each questionName with its response value
|
|
while ( my ( $questionName, $response ) = each %$responses ) {
|
|
$rest =~ s/$questionName/$response/g;
|
|
}
|
|
|
|
# convert '=' to '==' but don't touch '!=', '<=' or '>='
|
|
$rest =~ s/(?<![!<>])=(?!=)/==/g;
|
|
|
|
if ( $rest !~ /^$tokens+$/ ) {
|
|
$self->session->log->warn("Contains invalid tokens: $rest");
|
|
return;
|
|
}
|
|
|
|
$self->session->log->debug("Processed as: $rest");
|
|
|
|
return {
|
|
target => $target,
|
|
expression => $rest,
|
|
};
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 getPreviousAnswer
|
|
|
|
=cut
|
|
|
|
sub getPreviousAnswer {
|
|
my $self = shift;
|
|
my $questionParam = shift;
|
|
for my $q ( @{ $self->surveyOrder } ) {
|
|
my $question = $self->survey->question( [ $$q[0], $$q[1] ] );
|
|
if ( $question->{variable} eq $questionParam ) {
|
|
for ( 0 .. @{ $self->survey->answers( [ $$q[0], $$q[1] ] ) } ) {
|
|
if ( exists $self->responses->{ $$q[0] . "-" . $$q[1] . "-" . $_ } ) {
|
|
return $self->responses->{ $$q[0] . "-" . $$q[1] . "-" . $_ }->{value};
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 nextQuestions
|
|
|
|
Returns an array ref of the next questions in the survey. The number of questions
|
|
returned is set by the questionsPerPage property of the next section, as determined
|
|
by nextSectionId rather than logical section ordering.
|
|
|
|
If no questions are available, then it returns an empty array ref.
|
|
|
|
Each element of the array ref is a question data structure, from the
|
|
WebGUI::Asset::Wobject::Survey::SurveyJSON class, with a section sid field (index of
|
|
the containing section) and question id (section and question id concatenated with a
|
|
'-') added. The answers array of the question contains answer data structures, also
|
|
from WebGUI::Asset::Wobject::Survey::SurveyJSON, with an id field which is the section,
|
|
question and answer indexes concatentated together with dashes.
|
|
|
|
Section and question [[var]] replacements in text fields.
|
|
|
|
All questions and answers are safe copies of the survey data.
|
|
|
|
=cut
|
|
|
|
sub nextQuestions {
|
|
my $self = shift;
|
|
|
|
return [] if $self->surveyEnd;
|
|
|
|
my $nextSectionId = $self->nextSectionId;
|
|
|
|
my $qPerPage = $self->survey->section( [ $self->nextSectionId ] )->{questionsPerPage};
|
|
|
|
#load Previous answer text
|
|
my $section = $self->nextSection();
|
|
$section->{'text'} =~ s/\[\[([^\%]*?)\]\]/$self->getPreviousAnswer($1)/eg;
|
|
|
|
my $questions;
|
|
for ( my $i = 1; $i <= $qPerPage; $i++ ) {
|
|
my $qAddy = $self->surveyOrder->[ $self->lastResponse + $i ];
|
|
next
|
|
if ( !exists $$qAddy[1] ); #skip this if it doesn't have a question (for sections with no questions)
|
|
|
|
if ( $$qAddy[0] != $nextSectionId ) {
|
|
last;
|
|
}
|
|
my %question = %{ $self->survey->question( [ $$qAddy[0], $$qAddy[1] ] ) };
|
|
$question{'text'} =~ s/\[\[([^\%]*?)\]\]/$self->getPreviousAnswer($1)/eg;
|
|
delete $question{answers};
|
|
$question{id} = "$$qAddy[0]-$$qAddy[1]";
|
|
$question{sid} = "$$qAddy[0]";
|
|
for ( @{ $$qAddy[2] } ) {
|
|
my %ans = %{ $self->survey->answer( [ $$qAddy[0], $$qAddy[1], $_ ] ) };
|
|
$ans{'text'} =~ s/\[\[([^\%]*?)\]\]/$self->getPreviousAnswer($1)/eg;
|
|
$ans{id} = "$$qAddy[0]-$$qAddy[1]-$_";
|
|
push( @{ $question{answers} }, \%ans );
|
|
}
|
|
push( @$questions, \%question );
|
|
} ## end for ( my $i = 1; $i <= ...
|
|
return $questions;
|
|
} ## end sub nextQuestions
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=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 returnResponsesForReporting
|
|
|
|
=cut
|
|
|
|
sub returnResponseForReporting {
|
|
my $self = shift;
|
|
my @responses = ();
|
|
for my $entry ( @{ $self->surveyOrder } ) {
|
|
if ( @$entry == 1 ) {
|
|
next;
|
|
}
|
|
my @answers;
|
|
for ( @{ $$entry[2] } ) {
|
|
if ( defined $self->responses->{"$$entry[0]-$$entry[1]-$_"} ) {
|
|
$self->responses->{"$$entry[0]-$$entry[1]-$_"}->{id} = $_;
|
|
if ( $self->survey->answer( [ $$entry[0], $$entry[1], $_ ] )->{isCorrect} ) {
|
|
my $value;
|
|
if ( $self->survey->answer( [ $$entry[0], $$entry[1], $_ ] )->{value} =~ /\w/ ) {
|
|
$value = $self->survey->answer( [ $$entry[0], $$entry[1], $_ ] )->{value};
|
|
}
|
|
else {
|
|
$value = $self->survey->question( [ $$entry[0], $$entry[1] ] )->{value};
|
|
}
|
|
$self->responses->{"$$entry[0]-$$entry[1]-$_"}->{value} = $value;
|
|
$self->responses->{"$$entry[0]-$$entry[1]-$_"}->{isCorrect} = 1;
|
|
}
|
|
else {
|
|
$self->responses->{"$$entry[0]-$$entry[1]-$_"}->{isCorrect} = 0;
|
|
}
|
|
push( @answers, ( $self->responses->{"$$entry[0]-$$entry[1]-$_"} ) );
|
|
} ## end if ( defined $self->responses...
|
|
} ## end for ( @{ $$entry[2] } )
|
|
push(
|
|
@responses, ( {
|
|
'section', $$entry[0],
|
|
'question', $$entry[1],
|
|
'sectionName', $self->survey->section( [ $$entry[0] ] )->{variable},
|
|
'questionName', $self->survey->question( [ $$entry[0], $$entry[1] ] )->{variable},
|
|
'questionComment', $self->responses->{"$$entry[0]-$$entry[1]"}->{comment},
|
|
'answers', \@answers
|
|
}
|
|
)
|
|
);
|
|
} ## end for my $entry ( @{ $self...
|
|
return \@responses;
|
|
} ## end sub returnResponseForReporting
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
#the actual responses to the survey. A response is for a question and is accessed by the exact same address as a survey member.
|
|
#Questions only contain the comment and an array of answer Responses.
|
|
#Answers only contain, entered text, entered verbatim, their index in the Survey Question Answer array, and the assetId to the uploaded file.
|
|
|
|
=head2 responses
|
|
|
|
Returns a reference to the actual responses to the survey. A response is for a question and
|
|
is accessed by the exact same address as a survey member. Questions only contain the comment
|
|
and an array of answer Responses. Answers only contain, entered text, entered verbatim,
|
|
their index in the Survey Question Answer array, and the assetId to the uploaded file.
|
|
|
|
Note, this is an unsafe reference.
|
|
|
|
=cut
|
|
|
|
sub responses {
|
|
my $self = shift;
|
|
return $self->{responses};
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 responses
|
|
|
|
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;
|