merge to 10219
This commit is contained in:
Colin Kuskie
parent
ae28bf79c8
commit
4c1307e3d0
194 changed files with 8203 additions and 2134 deletions
217
lib/WebGUI/Asset/Wobject/Survey/ExpressionEngine.pm
Normal file
217
lib/WebGUI/Asset/Wobject/Survey/ExpressionEngine.pm
Normal file
|
|
@ -0,0 +1,217 @@
|
|||
package WebGUI::Asset::Wobject::Survey::ExpressionEngine;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Asset::Wobject::Survey::ExpressionEngine
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class is used to process Survey gotoExpressions.
|
||||
|
||||
See L<run> for more details.
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use Params::Validate qw(:all);
|
||||
use Safe;
|
||||
use Data::Dumper;
|
||||
use List::Util qw/sum/;
|
||||
Params::Validate::validation_options( on_fail => sub { WebGUI::Error::InvalidParam->throw( error => shift ) } );
|
||||
|
||||
# We need these as semi-globals so that utility subs (which are shared with the safe compartment)
|
||||
# can access them.
|
||||
my $session;
|
||||
my $values;
|
||||
my $scores;
|
||||
my $jump_count;
|
||||
my $validate;
|
||||
my $validTargets;
|
||||
|
||||
=head2 value
|
||||
|
||||
Utility sub that gives expressions access to recorded response values
|
||||
|
||||
value(question_variable) returns the recorded response value for the answer to question_variable
|
||||
|
||||
=cut
|
||||
|
||||
sub value($) {
|
||||
my $key = shift;
|
||||
my $value = $values->{$key};
|
||||
$session->log->debug("[$key] resolves to [$value]");
|
||||
return $value; # scalar variable, so no need to clone
|
||||
}
|
||||
|
||||
=head2 score
|
||||
|
||||
Utility sub that gives expressions access to recorded response scores.
|
||||
|
||||
score(question_variable) returns the score for the answer selected for question_variable
|
||||
score(section_variable) returns the summed score for the answers to all the questions in section_variable
|
||||
|
||||
=cut
|
||||
|
||||
sub score($) {
|
||||
my $key = shift;
|
||||
my $score = $scores->{$key};
|
||||
$session->log->debug("[$key] resolves to [$score]");
|
||||
return $score; # scalar variable, so no need to clone
|
||||
}
|
||||
|
||||
=head2 jump
|
||||
|
||||
Utility sub shared with Safe compartment so that expressions can call individual jump tests.
|
||||
|
||||
Throws an exception containing the jump target when a jump matches, thus allowing L<run> to
|
||||
catch the first successful jump.
|
||||
|
||||
=cut
|
||||
|
||||
sub jump(&$) {
|
||||
my ( $sub, $target ) = @_;
|
||||
$jump_count++;
|
||||
|
||||
# If $validTargets known, make sure target is valid
|
||||
if ($validTargets && !exists $validTargets->{$target}) {
|
||||
$session->log->debug("Invalid target [$target]");
|
||||
if ($validate) {
|
||||
die("Invalid jump target \"$target\""); # bail and report error
|
||||
} else {
|
||||
return; # skip jump but continue with expression
|
||||
}
|
||||
}
|
||||
|
||||
if ( $sub->() ) {
|
||||
$session->log->debug("jump call #$jump_count is truthy");
|
||||
die( { jump => $target } );
|
||||
}
|
||||
else {
|
||||
$session->log->debug("jump call #$jump_count is falsey");
|
||||
}
|
||||
}
|
||||
|
||||
=head2 avg
|
||||
|
||||
Utility sub shared with Safe compartment to allows expressions to easily compute the average of a list
|
||||
|
||||
=cut
|
||||
|
||||
sub avg {
|
||||
my @vals = @_;
|
||||
return sum(@vals) / @vals;
|
||||
}
|
||||
|
||||
=head2 run ( $session, $expression, $opts )
|
||||
|
||||
Class method.
|
||||
|
||||
Evaluates the given expression in a Safe compartment.
|
||||
|
||||
=head3 session
|
||||
|
||||
A WebGUI::Session
|
||||
|
||||
=head3 expression
|
||||
|
||||
The expression to run.
|
||||
|
||||
A gotoExpression is essentially a perl expression that gets evaluated in a Safe compartment.
|
||||
|
||||
To access Section/Question recorded response values, the expression calls L<value>.
|
||||
To access Section/Question recorded response scores, the expression calls L<score>.
|
||||
To trigger a jump, the expression calls L<jump>. The first truthy jump succeeds.
|
||||
We also give expressions access to some useful utility subs such as avg(), and all of the
|
||||
handy subs from List::Util (min, max, sum, etc..).
|
||||
|
||||
A very simple expression that checks if the response to s1q1 is 0 might look like:
|
||||
|
||||
jump { value(s1q1) == 0 } target
|
||||
|
||||
A more complicated gotoExpression with two possible jumps might look like:
|
||||
|
||||
jump { value(q1) > 5 and value(s2q1) =~ m/textmatch/ } target1;
|
||||
jump { avg(value(q1), value(q2), value(q3)) > 10 } target2;
|
||||
|
||||
=head3 opts (optional)
|
||||
|
||||
Supported options are:
|
||||
|
||||
=over 3
|
||||
|
||||
=item * values
|
||||
|
||||
Hashref of values to make available to the expression via the L<value> utility sub
|
||||
|
||||
=item * scores
|
||||
|
||||
Hashref of scores to make available to the expression via the L<score> utility sub
|
||||
|
||||
=item* validTargets
|
||||
|
||||
A hashref of valid jump targets. If this is provided, all L<jump> calls will fail unless
|
||||
the specified target is a key in the hashref.
|
||||
|
||||
=item * validate
|
||||
|
||||
Return errors rather than just logging them (useful for displaying survey validation errors to users)
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub run {
|
||||
my $class = shift;
|
||||
my ( $s, $expression, $opts )
|
||||
= validate_pos( @_, { isa => 'WebGUI::Session' }, { type => SCALAR }, { type => HASHREF, default => {} } );
|
||||
|
||||
# Init package globals
|
||||
( $session, $values, $scores, $jump_count, $validate, $validTargets ) = ( $s, $opts->{values}, $opts->{scores}, 0, $opts->{validate}, $opts->{validTargets} );
|
||||
|
||||
if (!$session->config->get('enableSurveyExpressionEngine')) {
|
||||
$session->log->debug('enableSurveyExpressionEngine config option disabled, skipping');
|
||||
return;
|
||||
}
|
||||
|
||||
# Create the Safe compartment
|
||||
my $compartment = Safe->new();
|
||||
|
||||
# Share our utility subs with the compartment
|
||||
$compartment->share('&value');
|
||||
$compartment->share('&score');
|
||||
$compartment->share('&jump');
|
||||
$compartment->share('&avg');
|
||||
|
||||
# Give them all of List::Util too
|
||||
$compartment->share_from('List::Util', ['&first', '&max', '&maxstr', '&min', '&minstr', '&reduce', '&shuffle', '&sum',]);
|
||||
|
||||
$session->log->debug("Expression is: \"$expression\"");
|
||||
$compartment->reval($expression);
|
||||
|
||||
# See if we ran the engine just to check for errors
|
||||
if ($opts->{validate}) {
|
||||
if ($@ && ref $@ ne 'HASH') {
|
||||
my $error = $@;
|
||||
$error =~ s/(.*?) at .*/$1/s; # don't reveal too much
|
||||
return $error;
|
||||
}
|
||||
return; # no validation errors
|
||||
}
|
||||
|
||||
# A successful jump triggers a hashref containing the jump target to be thrown
|
||||
if ( ref $@ && ref $@ eq 'HASH' && $@->{jump} ) {
|
||||
my $jump = $@->{jump};
|
||||
$session->log->debug("Returning [$jump]");
|
||||
return $jump;
|
||||
}
|
||||
|
||||
# Log all other errors (for example compile errors from bad expressions)
|
||||
if ($@) {
|
||||
$session->log->error($@);
|
||||
}
|
||||
|
||||
# Return undef on failure
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -28,7 +28,7 @@ As a whole, this class represents the complete state of a user's response to a S
|
|||
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).
|
||||
|
||||
|
|
@ -40,7 +40,7 @@ number of questions answered (L<"questionsAnswered">) and the Survey start time
|
|||
This package is not intended to be used by any other Asset in WebGUI.
|
||||
|
||||
=head2 surveyOrder
|
||||
|
||||
|
||||
This data strucutre is an array (reference) of Survey addresses (see
|
||||
L<WebGUI::Asset::Wobject::Survey::SurveyJSON/Address Parameter>), stored in the order
|
||||
in which items are presented to the user.
|
||||
|
|
@ -70,7 +70,7 @@ 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:
|
||||
{
|
||||
...
|
||||
|
|
@ -79,7 +79,7 @@ Question entries only contain a comment field:
|
|||
}
|
||||
...
|
||||
}
|
||||
|
||||
|
||||
Answers entries contain: value (the recorded value), time and comment fields.
|
||||
|
||||
{
|
||||
|
|
@ -98,6 +98,7 @@ 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 ) } );
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
@ -430,9 +431,9 @@ Processes and records submitted survey responses in the L<"responses"> data stru
|
|||
Does terminal handling, and branch processing, and advances the L<"lastResponse"> index
|
||||
if all required questions have been answered.
|
||||
|
||||
=head3 $responses
|
||||
=head3 $submittedResponses
|
||||
|
||||
A hash ref of form param data. Each element should look like:
|
||||
A hash ref of submitted form param data. Each element should look like:
|
||||
|
||||
{
|
||||
"questionId-comment" => "question comment",
|
||||
|
|
@ -459,11 +460,11 @@ gotoExpression in the set of questions wins.
|
|||
|
||||
sub recordResponses {
|
||||
my $self = shift;
|
||||
my ($responses) = validate_pos( @_, { type => HASHREF } );
|
||||
my ($submittedResponses) = validate_pos( @_, { type => HASHREF } );
|
||||
|
||||
# Build a lookup table of non-multiple choice question types
|
||||
my %knownTypes = map {$_ => 1} $self->survey->specialQuestionTypes;
|
||||
|
||||
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();
|
||||
|
|
@ -517,37 +518,40 @@ sub recordResponses {
|
|||
}
|
||||
|
||||
# Record Question comment
|
||||
$self->responses->{ $question->{id} }->{comment} = $responses->{ $question->{id} . '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 $answerValue = $responses->{ $answer->{id} };
|
||||
my $answerComment = $responses->{ $answer->{id} . 'comment' };
|
||||
my $submittedAnswerResponse = $submittedResponses->{ $answer->{id} };
|
||||
my $submittedAnswerComment = $submittedResponses->{ $answer->{id} . 'comment' };
|
||||
|
||||
# Proceed if we're satisfied that response is valid..
|
||||
if ( defined $answerValue && $answerValue =~ /\S/ ) {
|
||||
# Proceed if we're satisfied that the submitted answer response is valid..
|
||||
if ( defined $submittedAnswerResponse && $submittedAnswerResponse =~ /\S/ ) {
|
||||
$aAnswered = 1;
|
||||
if ($knownTypes{$question->{questionType}}) {
|
||||
$self->responses->{ $answer->{id} }->{value} = $answerValue;
|
||||
} else {
|
||||
# Unknown type, must be a multi-choice bundle
|
||||
# For Multi-choice, use recordedAnswer instead of answerValue
|
||||
$self->responses->{ $answer->{id} }->{value} = $answer->{recordedAnswer};
|
||||
}
|
||||
$self->responses->{ $answer->{id} }->{time} = time;
|
||||
$self->responses->{ $answer->{id} }->{comment} = $answerComment;
|
||||
|
||||
# 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} }->{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};
|
||||
|
|
@ -645,89 +649,26 @@ indicates that we should branch.
|
|||
|
||||
=head3 $gotoExpression
|
||||
|
||||
The gotoExpression.
|
||||
|
||||
A gotoExpression is a string representing 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
|
||||
|
||||
Arguments are evaluated as follows:
|
||||
|
||||
Numeric arguments evaluate as numbers
|
||||
|
||||
=over 4
|
||||
|
||||
=item * No support for strings (and hence no string matching)
|
||||
|
||||
=item * 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
|
||||
|
||||
=back
|
||||
|
||||
Binary comparisons operators: = != < <= >= >
|
||||
|
||||
=over 4
|
||||
|
||||
=item * return boolean values based on perl's equivalent numeric comparison operators
|
||||
|
||||
=back
|
||||
|
||||
Simple math operators: + - * /
|
||||
|
||||
=over 4
|
||||
|
||||
=item * return numeric values
|
||||
|
||||
=back
|
||||
|
||||
Later we may add Boolean operators: AND( x; y; z; ... ), OR( x; y; z; ... ), NOT( x ), with 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.
|
||||
The gotoExpression. See L<WebGUI::Asset::Wobject::Survey::ExpressionEngine> for more info.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub processGotoExpression {
|
||||
my $self = shift;
|
||||
my ($expression) = validate_pos(@_, {type => SCALAR});
|
||||
|
||||
my $responses = $self->recordedResponses();
|
||||
|
||||
# Parse gotoExpressions one after the other (first one that's true wins)
|
||||
foreach my $line (split /\n/, $expression) {
|
||||
my $processed = $self->parseGotoExpression($line, $responses);
|
||||
|
||||
next if !$processed;
|
||||
|
||||
# (ab)use perl's eval to evaluate the processed expression
|
||||
my $result = eval "$processed->{expression}"; ## no critic
|
||||
$self->session->log->warn($@) if $@; ## no critic
|
||||
|
||||
if ($result) {
|
||||
$self->session->log->debug("Truthy, goto [$processed->{target}]");
|
||||
$self->processGoto($processed->{target});
|
||||
return $processed;
|
||||
} else {
|
||||
$self->session->log->debug('Falsy, not branching');
|
||||
next;
|
||||
}
|
||||
|
||||
# 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;
|
||||
}
|
||||
|
||||
|
|
@ -735,111 +676,129 @@ sub processGotoExpression {
|
|||
|
||||
=head2 recordedResponses
|
||||
|
||||
Returns a hash (reference) of question responses. The hash keys are
|
||||
question variable names. The hash values are the corresponding answer
|
||||
values selected by the user.
|
||||
Returns an array or response information in this response's survey order.
|
||||
|
||||
=cut
|
||||
|
||||
sub recordedResponses {
|
||||
sub recordedResponses{
|
||||
my $self = shift;
|
||||
|
||||
my $responses= {
|
||||
# questionName => response answer value
|
||||
};
|
||||
|
||||
# Populate %responses with the user's data..
|
||||
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 ] );
|
||||
$responses->{$question->{variable}}
|
||||
= $answer->{value} =~ /\w/ ? $answer->{value}
|
||||
: $question->{value}
|
||||
;
|
||||
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 parseGotoExpression( ( $expression, $responses)
|
||||
=head2 responseValuesByVariableName
|
||||
|
||||
Parses a single gotoExpression. Returns undef if processing fails, or the following hashref
|
||||
if things work out well:
|
||||
{ target => $target, expression => $expression }
|
||||
Returns a lookup table to question variable names and recorded response values.
|
||||
|
||||
=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
|
||||
Only questions with a defined variable name set are included. Values come from
|
||||
the L<responses> hash.
|
||||
|
||||
=cut
|
||||
|
||||
sub parseGotoExpression {
|
||||
my $self = shift;
|
||||
my ($expression, $responses) = validate_pos(@_, { type => SCALAR }, { type => HASHREF, default => {} });
|
||||
|
||||
$self->session->log->debug("Parsing 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;
|
||||
sub responseValuesByVariableName {
|
||||
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};
|
||||
|
||||
# Add variable => value to our hash
|
||||
$lookup{$question->{variable}} = $response->{value};
|
||||
}
|
||||
return \%lookup;
|
||||
}
|
||||
|
||||
if ( !defined $rest || $rest eq q{} ) {
|
||||
$self->session->log->warn('Expression undefined');
|
||||
return;
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=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]);
|
||||
|
||||
# Add variable => score to our hash
|
||||
$lookup{$question->{variable}} = $answer->{value};
|
||||
}
|
||||
|
||||
# Replace each questionName with its response value
|
||||
while ( my ( $questionName, $response ) = each %{$responses} ) {
|
||||
$rest =~ s/$questionName/$response/g;
|
||||
|
||||
# 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}};
|
||||
}
|
||||
}
|
||||
|
||||
# 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,
|
||||
};
|
||||
|
||||
return \%lookup;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
@ -915,11 +874,12 @@ sub nextQuestions {
|
|||
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 $recordedResponses = $self->recordedResponses();
|
||||
my $responseValuesByVariableName = $self->responseValuesByVariableName();
|
||||
|
||||
# Do text replacement
|
||||
$section->{text} = $self->getTemplatedText($section->{text}, $recordedResponses);
|
||||
$section->{text} = $self->getTemplatedText($section->{text}, $responseValuesByVariableName);
|
||||
|
||||
# Collect all the questions to be shown on the next page..
|
||||
my @questions;
|
||||
|
|
@ -942,7 +902,7 @@ sub nextQuestions {
|
|||
my %questionCopy = %{$self->survey->question( $address )};
|
||||
|
||||
# Do text replacement
|
||||
$questionCopy{text} = $self->getTemplatedText($questionCopy{text}, $recordedResponses);
|
||||
$questionCopy{text} = $self->getTemplatedText($questionCopy{text}, $responseValuesByVariableName);
|
||||
|
||||
# Add any extra fields we want..
|
||||
$questionCopy{id} = $self->questionId($sIndex, $qIndex);
|
||||
|
|
@ -954,7 +914,7 @@ sub nextQuestions {
|
|||
my %answerCopy = %{ $self->survey->answer( [ $sIndex, $qIndex, $aIndex ] ) };
|
||||
|
||||
# Do text replacement
|
||||
$answerCopy{text} = $self->getTemplatedText($answerCopy{text}, $recordedResponses);
|
||||
$answerCopy{text} = $self->getTemplatedText($answerCopy{text}, $responseValuesByVariableName);
|
||||
|
||||
# Add any extra fields we want..
|
||||
$answerCopy{id} = $self->answerId($sIndex, $qIndex, $aIndex);
|
||||
|
|
@ -1086,7 +1046,116 @@ sub aIndexes {
|
|||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 returnResponsesForReporting
|
||||
=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, $questionIndex, $answerIndex) = (-1, -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++;
|
||||
$questionIndex = -1;
|
||||
$answerIndex = -1;
|
||||
$currentQuestion = -1;
|
||||
$currentSection = $response->{address}->[0];
|
||||
_loadSectionIntoSummary(\%{$summaries->{sections}->[$sectionIndex]},$response);
|
||||
}
|
||||
if($currentQuestion != $response->{address}->[1]){
|
||||
$summaries->{totalQuestions}++;
|
||||
$questionIndex++;
|
||||
$answerIndex = -1;
|
||||
$currentQuestion = $response->{address}->[1];
|
||||
_loadQuestionIntoSummary(\%{$summaries->{sections}->[$sectionIndex]->{questions}->[$questionIndex]},$response);
|
||||
}
|
||||
$answerIndex++;
|
||||
_loadAnswerIntoSummary(\%{$summaries->{sections}->[$sectionIndex]->{questions}->[$questionIndex]->{answers}->[$answerIndex]},
|
||||
$response,
|
||||
$self->survey->{multipleChoiceTypes});
|
||||
}
|
||||
return $summaries;
|
||||
}
|
||||
sub _loadAnswerIntoSummary{
|
||||
my $node = shift;
|
||||
my $response = shift;
|
||||
my $types = shift;
|
||||
|
||||
$node->{id} = $response->{address}->[2] + 1;
|
||||
if($response->{isCorrect}){
|
||||
$node->{iscorrect} = 1;
|
||||
$node->{score} = $response->{value};
|
||||
}else{
|
||||
$node->{iscorrect} = 0;
|
||||
$node->{score} = 0;
|
||||
}
|
||||
$node->{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 _loadQuestionIntoSummary{
|
||||
my $node = shift;
|
||||
my $response = shift;
|
||||
$node->{id} = $response->{address}->[1] + 1;
|
||||
$node->{text} = $response->{questionText};
|
||||
}
|
||||
sub _loadSectionIntoSummary{
|
||||
my $node = shift;
|
||||
my $response = shift;
|
||||
$node->{id} = $response->{address}->[0] + 1;
|
||||
$node->{inCorrect} = 0 if(!defined $node->{section}->{inCorrect});
|
||||
$node->{score} = 0 if(!defined $node->{section}->{score});
|
||||
$node->{correct} = 0 if(!defined $node->{section}->{correct});
|
||||
if($response->{isCorrect}){
|
||||
$node->{score} += $response->{value};
|
||||
$node->{correct}++;
|
||||
}else{
|
||||
$node->{inCorrect}++;
|
||||
}
|
||||
|
||||
}
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 returnResponseForReporting
|
||||
|
||||
Used to extract JSON responses for use in reporting results.
|
||||
|
||||
|
|
@ -1096,7 +1165,7 @@ recorded value, and the id of the answer.
|
|||
|
||||
=cut
|
||||
|
||||
# TODO: This sub should make use of recordedResponses
|
||||
# TODO: This sub should make use of responseValuesByVariableName
|
||||
|
||||
sub returnResponseForReporting {
|
||||
my $self = shift;
|
||||
|
|
|
|||
|
|
@ -48,79 +48,18 @@ likely operate on the question indexed by:
|
|||
|
||||
use strict;
|
||||
use JSON;
|
||||
use Data::Dumper;
|
||||
use Params::Validate qw(:all);
|
||||
Params::Validate::validation_options( on_fail => sub { WebGUI::Error::InvalidParam->throw( error => shift ) } );
|
||||
|
||||
# N.B. We're currently using Storable::dclone instead of Clone::clone
|
||||
# because Colin uncovered some Clone bugs in Perl 5.10
|
||||
#use Clone qw/clone/;
|
||||
use Storable qw/dclone/;
|
||||
use Clone qw/clone/;
|
||||
|
||||
# The maximum value of questionsPerPage is currently hardcoded here
|
||||
my $MAX_QUESTIONS_PER_PAGE = 20;
|
||||
|
||||
my %MULTI_CHOICE_BUNDLES = (
|
||||
'Agree/Disagree' => [ 'Strongly disagree', (q{}) x 5, 'Strongly agree' ],
|
||||
Certainty => [ 'Not at all certain', (q{}) x 9, 'Extremely certain' ],
|
||||
Concern => [ 'Not at all concerned', (q{}) x 9, 'Extremely concerned' ],
|
||||
Confidence => [ 'Not at all confident', (q{}) x 9, 'Extremely confident' ],
|
||||
Education => [
|
||||
'Elementary or some high school',
|
||||
'High school/GED',
|
||||
'Some college/vocational school',
|
||||
'College graduate',
|
||||
'Some graduate work',
|
||||
'Master\'s degree',
|
||||
'Doctorate (of any type)',
|
||||
'Other degree (verbatim)',
|
||||
],
|
||||
Effectiveness => [ 'Not at all effective', (q{}) x 9, 'Extremely effective' ],
|
||||
Gender => [qw( Male Female )],
|
||||
Ideology => [
|
||||
'Strongly liberal',
|
||||
'Liberal',
|
||||
'Somewhat liberal',
|
||||
'Middle of the road',
|
||||
'Slightly conservative',
|
||||
'Conservative',
|
||||
'Strongly conservative'
|
||||
],
|
||||
Importance => [ 'Not at all important', (q{}) x 9, 'Extremely important' ],
|
||||
Likelihood => [ 'Not at all likely', (q{}) x 9, 'Extremely likely' ],
|
||||
'Oppose/Support' => [ 'Strongly oppose', (q{}) x 5, 'Strongly support' ],
|
||||
Party =>
|
||||
[ 'Democratic party', 'Republican party (or GOP)', 'Independent party', 'Other party (verbatim)' ],
|
||||
Race =>
|
||||
[ 'American Indian', 'Asian', 'Black', 'Hispanic', 'White non-Hispanic', 'Something else (verbatim)' ],
|
||||
Risk => [ 'No risk', (q{}) x 9, 'Extreme risk' ],
|
||||
Satisfaction => [ 'Not at all satisfied', (q{}) x 9, 'Extremely satisfied' ],
|
||||
Security => [ 'Not at all secure', (q{}) x 9, 'Extremely secure' ],
|
||||
Threat => [ 'No threat', (q{}) x 9, 'Extreme threat' ],
|
||||
'True/False' => [qw( True False )],
|
||||
'Yes/No' => [qw( Yes No )],
|
||||
Scale => [q{}],
|
||||
'Multiple Choice' => [q{}],
|
||||
);
|
||||
|
||||
my @SPECIAL_QUESTION_TYPES = (
|
||||
'Dual Slider - Range',
|
||||
'Multi Slider - Allocate',
|
||||
'Slider',
|
||||
'Currency',
|
||||
'Email',
|
||||
'Phone Number',
|
||||
'Text',
|
||||
'Text Date',
|
||||
'TextArea',
|
||||
'File Upload',
|
||||
'Date',
|
||||
'Date Range',
|
||||
'Hidden',
|
||||
);
|
||||
|
||||
sub specialQuestionTypes {
|
||||
return @SPECIAL_QUESTION_TYPES;
|
||||
}
|
||||
#sub specialQuestionTypes {
|
||||
# return @SPECIAL_QUESTION_TYPES;
|
||||
#}
|
||||
|
||||
=head2 new ( $session, json )
|
||||
|
||||
|
|
@ -153,6 +92,9 @@ sub new {
|
|||
|
||||
bless $self, $class;
|
||||
|
||||
#Load question types
|
||||
$self->loadTypes();
|
||||
|
||||
# Initialise the survey data structure if empty..
|
||||
if ( $self->totalSections == 0 ) {
|
||||
$self->newObject( [] );
|
||||
|
|
@ -160,6 +102,78 @@ sub new {
|
|||
return $self;
|
||||
}
|
||||
|
||||
=head2 loadTypes
|
||||
|
||||
Loads the Multiple Choice and Special Question types
|
||||
|
||||
=cut
|
||||
|
||||
sub loadTypes {
|
||||
my $self = shift;
|
||||
@{$self->{specialQuestionTypes}} = (
|
||||
'Dual Slider - Range',
|
||||
'Multi Slider - Allocate',
|
||||
'Slider',
|
||||
'Currency',
|
||||
'Email',
|
||||
'Phone Number',
|
||||
'Text',
|
||||
'Text Date',
|
||||
'TextArea',
|
||||
'File Upload',
|
||||
'Date',
|
||||
'Date Range',
|
||||
'Year Month',
|
||||
'Hidden',
|
||||
);
|
||||
my $refs = $self->session->db->buildArrayRefOfHashRefs("SELECT questionType, answers FROM Survey_questionTypes");
|
||||
map($self->{multipleChoiceTypes}->{$_->{questionType}} = [split/,/,$_->{answers}], @$refs);
|
||||
}
|
||||
|
||||
sub addType {
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
my $address = shift;
|
||||
my $obj = $self->getObject($address);
|
||||
my @answers;
|
||||
for my $ans(@{$obj->{answers}}){
|
||||
push(@answers,$ans->{text});
|
||||
}
|
||||
my $ansString = join(',',@answers);
|
||||
$self->session->db->write("INSERT INTO Survey_questionTypes VALUES(?,?) ON DUPLICATE KEY UPDATE answers = ?",[$name,$ansString,$ansString]);
|
||||
$self->question($address)->{questionType} = $name;
|
||||
}
|
||||
|
||||
|
||||
sub removeType {
|
||||
my $self = shift;
|
||||
my $address = shift;
|
||||
my $obj = $self->getObject($address);
|
||||
$self->session->db->write("DELETE FROM Survey_questionTypes WHERE questionType = ?",[$obj->{questionType}]);
|
||||
}
|
||||
|
||||
=head2 specialQuestionTypes
|
||||
|
||||
Returns the arrayref to the special question types
|
||||
|
||||
=cut
|
||||
|
||||
sub specialQuestionTypes {
|
||||
my $self = shift;
|
||||
return $self->{specialQuestionTypes};
|
||||
}
|
||||
|
||||
=head2 multipleChoiceTypes
|
||||
|
||||
Returns the hashref to the multiple choice types
|
||||
|
||||
=cut
|
||||
|
||||
sub multipleChoiceTypes {
|
||||
my $self = shift;
|
||||
return $self->{multipleChoiceTypes};
|
||||
}
|
||||
|
||||
=head2 freeze
|
||||
|
||||
Serialize this Perl object into a JSON string. The serialized object is made up of the survey and sections
|
||||
|
|
@ -350,13 +364,13 @@ sub getObject {
|
|||
return if !$count;
|
||||
|
||||
if ( $count == 1 ) {
|
||||
return dclone $self->sections->[ sIndex($address) ];
|
||||
return clone $self->sections->[ sIndex($address) ];
|
||||
}
|
||||
elsif ( $count == 2 ) {
|
||||
return dclone $self->sections->[ sIndex($address) ]->{questions}->[ qIndex($address) ];
|
||||
return clone $self->sections->[ sIndex($address) ]->{questions}->[ qIndex($address) ];
|
||||
}
|
||||
else {
|
||||
return dclone $self->sections->[ sIndex($address) ]->{questions}->[ qIndex($address) ]->{answers}
|
||||
return clone $self->sections->[ sIndex($address) ]->{questions}->[ qIndex($address) ]->{answers}
|
||||
->[ aIndex($address) ];
|
||||
}
|
||||
}
|
||||
|
|
@ -403,12 +417,14 @@ sub getGotoTargets {
|
|||
|
||||
# Valid goto targets are all of the section variable names..
|
||||
my @section_vars = map {$_->{variable}} @{$self->sections};
|
||||
|
||||
|
||||
# ..and all of the question variable names..
|
||||
my @question_vars = map {$_->{variable}} @{$self->questions};
|
||||
|
||||
|
||||
# ..excluding the ones that are empty
|
||||
return grep { $_ ne q{} } (@section_vars, @question_vars);
|
||||
my @grep = grep { $_ ne q{} } (@section_vars, @question_vars);
|
||||
return \@grep;
|
||||
#return grep { $_ ne q{} } (@section_vars, @question_vars);
|
||||
}
|
||||
|
||||
=head2 getSectionEditVars ( $address )
|
||||
|
|
@ -512,7 +528,6 @@ sub getQuestionEditVars {
|
|||
|
||||
# Change questionType from a single element into an array of hashrefs which list the available
|
||||
# question types and which one is currently selected for this question..
|
||||
|
||||
for my $qType ($self->getValidQuestionTypes) {
|
||||
push @{ $var{questionType} }, {
|
||||
text => $qType,
|
||||
|
|
@ -529,7 +544,8 @@ A convenience method. Returns a list of question types.
|
|||
=cut
|
||||
|
||||
sub getValidQuestionTypes {
|
||||
return sort (@SPECIAL_QUESTION_TYPES, keys %MULTI_CHOICE_BUNDLES);
|
||||
my $self = shift;
|
||||
return sort (@{$self->{specialQuestionTypes}}, keys %{$self->{multipleChoiceTypes}});
|
||||
}
|
||||
|
||||
=head2 getAnswerEditVars ( $address )
|
||||
|
|
@ -761,14 +777,14 @@ sub copy {
|
|||
|
||||
if ( $count == 1 ) {
|
||||
# Clone the indexed section onto the end of the list of sections..
|
||||
push @{ $self->sections }, dclone $self->section($address);
|
||||
push @{ $self->sections }, clone $self->section($address);
|
||||
|
||||
# Update $address with the index of the newly created section
|
||||
$address->[0] = $self->lastSectionIndex;
|
||||
}
|
||||
elsif ( $count == 2 ) {
|
||||
# Clone the indexed question onto the end of the list of questions..
|
||||
push @{ $self->questions($address) }, dclone $self->question($address);
|
||||
push @{ $self->questions($address) }, clone $self->question($address);
|
||||
|
||||
# Update $address with the index of the newly created question
|
||||
$address->[1] = $self->lastQuestionIndex($address);
|
||||
|
|
@ -1002,7 +1018,7 @@ sub getMultiChoiceBundle {
|
|||
my $self = shift;
|
||||
my ($type) = validate_pos( @_, { type => SCALAR | UNDEF } );
|
||||
|
||||
return $MULTI_CHOICE_BUNDLES{$type};
|
||||
return $self->{multipleChoiceTypes}->{$type};
|
||||
}
|
||||
|
||||
=head2 addAnswersToQuestion ($address, $answers, $verbatims)
|
||||
|
|
@ -1047,7 +1063,7 @@ sub addAnswersToQuestion {
|
|||
$self->update(
|
||||
\@address_copy,
|
||||
{ text => $answers->[$answer_index],
|
||||
recordedAnswer => $answer_index + 1,
|
||||
recordedAnswer => $answer_index + 1, # 1-indexed
|
||||
verbatim => $verbatims->{$answer_index},
|
||||
}
|
||||
);
|
||||
|
|
@ -1176,6 +1192,123 @@ sub totalAnswers {
|
|||
}
|
||||
}
|
||||
|
||||
=head2 validateSurvey ()
|
||||
|
||||
Returns an array of messages to inform a user what is logically wrong with the Survey
|
||||
|
||||
=cut
|
||||
|
||||
sub validateSurvey{
|
||||
my $self = shift;
|
||||
#check all goto's
|
||||
#bad goto expressions
|
||||
#check that all survey is able to be seen
|
||||
|
||||
my @messages;
|
||||
|
||||
#set up valid goto targets
|
||||
my $gotoTargets = $self->getGotoTargets();
|
||||
my $goodTargets;
|
||||
my $duplicateTargets;
|
||||
for my $g (@{$gotoTargets}) {
|
||||
$goodTargets->{$g}++;
|
||||
$duplicateTargets->{$g}++ if $goodTargets->{$g} > 1;
|
||||
}
|
||||
|
||||
#step through each section validating it.
|
||||
my $sections = $self->sections();
|
||||
|
||||
for(my $s = 0; $s <= $#$sections; $s++){
|
||||
my $sNum = $s + 1;
|
||||
my $section = $self->section([$s]);
|
||||
if(! $self->validateGoto($section,$goodTargets)){
|
||||
push @messages,"Section $sNum has invalid Jump target: \"$section->{goto}\"";
|
||||
}
|
||||
if(! $self->validateGotoInfiniteLoop($section)){
|
||||
push @messages,"Section $sNum jumps to itself.";
|
||||
}
|
||||
if(my $error = $self->validateGotoExpression($section,$goodTargets)){
|
||||
push @messages,"Section $sNum has invalid Jump Expression: \"$section->{gotoExpression}\". Error: $error";
|
||||
}
|
||||
if (my $var = $section->{variable}) {
|
||||
if (my $count = $duplicateTargets->{$var}) {
|
||||
push @messages, "Section $sNum variable name $var is re-used in $count other place(s).";
|
||||
}
|
||||
}
|
||||
|
||||
#step through each question validating it.
|
||||
my $questions = $self->questions([$s]);
|
||||
for(my $q = 0; $q <= $#$questions; $q++){
|
||||
my $qNum = $q + 1;
|
||||
my $question = $self->question([$s,$q]);
|
||||
if(! $self->validateGoto($question,$goodTargets)){
|
||||
push @messages,"Section $sNum Question $qNum has invalid Jump target: \"$question->{goto}\"";
|
||||
}
|
||||
if(! $self->validateGotoInfiniteLoop($question)){
|
||||
push @messages,"Section $sNum Question $qNum jumps to itself.";
|
||||
}
|
||||
if(my $error = $self->validateGotoExpression($question,$goodTargets)){
|
||||
push @messages,"Section $sNum Question $qNum has invalid Jump Expression: \"$question->{gotoExpression}\". Error: $error";
|
||||
}
|
||||
if($#{$question->{answers}} < 0){
|
||||
push @messages,"Section $sNum Question $qNum does not have any answers.";
|
||||
}
|
||||
if(! $question->{text} =~ /\w/){
|
||||
push @messages,"Section $sNum Question $qNum does not have any text.";
|
||||
}
|
||||
if (my $var = $question->{variable}) {
|
||||
if (my $count = $duplicateTargets->{$var}) {
|
||||
push @messages, "Section $sNum Question $qNum variable name $var is re-used in $count other place(s).";
|
||||
}
|
||||
}
|
||||
|
||||
#step through each answer validating it.
|
||||
my $answers = $self->answers([$s,$q]);
|
||||
for(my $a = 0; $a <= $#$answers; $a++){
|
||||
my $aNum = $a + 1;
|
||||
my $answer = $self->answer([$s,$q,$a]);
|
||||
if(! $self->validateGoto($answer,$goodTargets)){
|
||||
push @messages,"Section $sNum Question $qNum Answer $aNum has invalid Jump target: \"$answer->{goto}\"";
|
||||
}
|
||||
if(! $self->validateGotoInfiniteLoop($answer)){
|
||||
push @messages,"Section $sNum Question $qNum Answer $aNum jumps to itself.";
|
||||
}
|
||||
if(my $error = $self->validateGotoExpression($answer,$goodTargets)){
|
||||
push @messages,"Section $sNum Question $qNum Answer $aNum has invalid Jump Expression: \"$answer->{gotoExpression}\". Error: $error";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return \@messages;
|
||||
}
|
||||
|
||||
sub validateGoto{
|
||||
my $self = shift;
|
||||
my $object = shift;
|
||||
my $goodTargets = shift;
|
||||
return 0 if($object->{goto} =~ /\w/ && ! exists($goodTargets->{$object->{goto}}));
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub validateGotoInfiniteLoop{
|
||||
my $self = shift;
|
||||
my $object = shift;
|
||||
return 0 if($object->{goto} =~ /\w/ and $object->{goto} eq $object->{variable});
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub validateGotoExpression{
|
||||
my $self = shift;
|
||||
my $object = shift;
|
||||
my $goodTargets = shift;
|
||||
return unless $object->{gotoExpression};
|
||||
|
||||
use WebGUI::Asset::Wobject::Survey::ExpressionEngine;
|
||||
my $engine = "WebGUI::Asset::Wobject::Survey::ExpressionEngine";
|
||||
return $engine->run($self->session, $object->{gotoExpression}, { validate => 1, validTargets => $goodTargets } );
|
||||
}
|
||||
|
||||
=head2 section ($address)
|
||||
|
||||
Returns a reference to one section.
|
||||
|
|
@ -1208,9 +1341,9 @@ sub session {
|
|||
|
||||
Returns a reference to all the questions from a particular section.
|
||||
|
||||
=head3 $address
|
||||
=head3 $address (optional)
|
||||
|
||||
See L<"Address Parameter">.
|
||||
See L<"Address Parameter">. If not defined, returns all questions.
|
||||
|
||||
=cut
|
||||
|
||||
|
|
@ -1218,7 +1351,13 @@ sub questions {
|
|||
my $self = shift;
|
||||
my ($address) = validate_pos(@_, { type => ARRAYREF, optional => 1});
|
||||
|
||||
return $self->sections->[ $address->[0] ]->{questions};
|
||||
if ($address) {
|
||||
return $self->sections->[ $address->[0] ]->{questions};
|
||||
} else {
|
||||
my $questions;
|
||||
push @$questions, @{$_->{questions} || []} for @{$self->sections};
|
||||
return $questions;
|
||||
}
|
||||
}
|
||||
|
||||
=head2 question ($address)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue