Survey Branch Expressions now allow you to "tag" data along the way and store
it in the response data structure along with the actual user input. Tag data can be used in subsequent expressions, in [[tag]] templated text replacement, and to classify responses in an arbitrary way. Refactored Survey expression utility subs that lookup values/scores/tags in external assets. Fixed bug whereby only highest precedence Survey expression was being evaluated rather than letting them all run and do their own short-circuiting.
This commit is contained in:
Patrick Donelan
parent
ac1a00b252
commit
3dda2b49d4
4 changed files with 322 additions and 119 deletions
|
|
@ -19,7 +19,6 @@ See L<run> for more details.
|
|||
use strict;
|
||||
use Params::Validate qw(:all);
|
||||
use Safe;
|
||||
use Data::Dumper;
|
||||
use List::Util qw/sum/;
|
||||
use WebGUI::Asset;
|
||||
Params::Validate::validation_options( on_fail => sub { WebGUI::Error::InvalidParam->throw( error => shift ) } );
|
||||
|
|
@ -29,10 +28,11 @@ Params::Validate::validation_options( on_fail => sub { WebGUI::Error::InvalidPar
|
|||
my $session;
|
||||
my $values;
|
||||
my $scores;
|
||||
my $jump_count;
|
||||
my $jumpCount;
|
||||
my $validate;
|
||||
my $validTargets;
|
||||
my $other_instances;
|
||||
my $otherInstances;
|
||||
my $tags;
|
||||
|
||||
=head2 value
|
||||
|
||||
|
|
@ -40,33 +40,38 @@ Utility sub that gives expressions access to recorded response values
|
|||
|
||||
Returns the recorded response value for the answer to question_variable
|
||||
|
||||
If two arguments are provided, the first argument is assumed to be an asset spec (assetId or url). In this
|
||||
case the sub is applied to the most recent completed response for the user on the survey instance given by asset_spec.
|
||||
|
||||
=cut
|
||||
|
||||
sub value {
|
||||
# Two arguments implies the first arg is an asset_spec
|
||||
if ( @_ == 2 ) {
|
||||
my ( $asset_spec, $key ) = @_;
|
||||
|
||||
# See if $other_instances already contains the external survey
|
||||
if (my $other_instance = $other_instances->{$asset_spec}) {
|
||||
my $values = $other_instance->{values};
|
||||
my $value = $values->{$key};
|
||||
$session->log->debug("value($asset_spec, $key) resolves to [$value]");
|
||||
return $value;
|
||||
} else {
|
||||
# Throw an exception, triggering run() to resolve the external reference and re-run
|
||||
die( { other_instance => $asset_spec } );
|
||||
}
|
||||
}
|
||||
my $key = shift;
|
||||
my $value = $values->{$key};
|
||||
my $value = $tags->{$key} || $values->{$key};
|
||||
$session->log->debug("value($key) resolves to [$value]");
|
||||
return $value; # scalar variable, so no need to clone
|
||||
}
|
||||
|
||||
=head2 valueX
|
||||
|
||||
Same as L<value>, except that first argument is an asset spec (assetId or url), which must resolve
|
||||
to a valid survey instance. The sub is applied to the most recent completed response for the user
|
||||
on the survey instance given by asset_spec.
|
||||
|
||||
=cut
|
||||
|
||||
sub valueX {
|
||||
my ( $asset_spec, $key ) = @_;
|
||||
|
||||
# See if $otherInstances already contains the external survey
|
||||
if (my $other_instance = $otherInstances->{$asset_spec}) {
|
||||
my $values = $other_instance->{values};
|
||||
my $value = $values->{$key};
|
||||
$session->log->debug("valueX($asset_spec, $key) resolves to [$value]");
|
||||
return $value;
|
||||
} else {
|
||||
# Throw an exception, triggering run() to resolve the external reference and re-run
|
||||
die( { other_instance => $asset_spec } );
|
||||
}
|
||||
}
|
||||
|
||||
=head2 score
|
||||
|
||||
Utility sub that gives expressions access to recorded response scores.
|
||||
|
|
@ -85,8 +90,8 @@ sub score {
|
|||
if ( @_ == 2 ) {
|
||||
my ( $asset_spec, $key ) = @_;
|
||||
|
||||
# See if $other_instances already contains the external survey
|
||||
if (my $other_instance = $other_instances->{$asset_spec}) {
|
||||
# See if $otherInstances already contains the external survey
|
||||
if (my $other_instance = $otherInstances->{$asset_spec}) {
|
||||
my $scores = $other_instance->{scores};
|
||||
my $score = $scores->{$key};
|
||||
$session->log->debug("score($asset_spec, $key) resolves to [$score]");
|
||||
|
|
@ -102,6 +107,29 @@ sub score {
|
|||
return $score; # scalar variable, so no need to clone
|
||||
}
|
||||
|
||||
=head2 scoreX
|
||||
|
||||
Same as L<score>, except that first argument is an asset spec (assetId or url), which must resolve
|
||||
to a valid survey instance. The sub is applied to the most recent completed response for the user
|
||||
on the survey instance given by asset_spec.
|
||||
|
||||
=cut
|
||||
|
||||
sub scoreX {
|
||||
my ( $asset_spec, $key ) = @_;
|
||||
|
||||
# See if $otherInstances already contains the external survey
|
||||
if (my $other_instance = $otherInstances->{$asset_spec}) {
|
||||
my $scores = $other_instance->{scores};
|
||||
my $score = $scores->{$key};
|
||||
$session->log->debug("scoreX($asset_spec, $key) resolves to [$score]");
|
||||
return $score;
|
||||
} else {
|
||||
# Throw an exception, triggering run() to resolve the external reference and re-run
|
||||
die( { other_instance => $asset_spec } );
|
||||
}
|
||||
}
|
||||
|
||||
=head2 answered
|
||||
|
||||
Returns true/false depending on whether use has actually reached and responded to the given question
|
||||
|
|
@ -112,27 +140,88 @@ case the sub is applied to the most recent completed response for the user on th
|
|||
=cut
|
||||
|
||||
sub answered {
|
||||
# Two arguments implies the first arg is an asset_spec
|
||||
if ( @_ == 2 ) {
|
||||
my ( $asset_spec, $key ) = @_;
|
||||
|
||||
# See if $other_instances already contains the external survey
|
||||
if (my $other_instance = $other_instances->{$asset_spec}) {
|
||||
my $values = $other_instance->{values};
|
||||
my $answered = exists $values->{$key};
|
||||
$session->log->debug("answered($asset_spec, $key) returns [$answered]");
|
||||
return $answered;
|
||||
} else {
|
||||
# Throw an exception, triggering run() to resolve the external reference and re-run
|
||||
die( { other_instance => $asset_spec } );
|
||||
}
|
||||
}
|
||||
my $key = shift;
|
||||
my $answered = exists $values->{$key};
|
||||
$session->log->debug("answered($key) returns [$answered]");
|
||||
return $answered;
|
||||
}
|
||||
|
||||
=head2 answeredX
|
||||
|
||||
Same as L<answered>, except that first argument is an asset spec (assetId or url), which must resolve
|
||||
to a valid survey instance. The sub is applied to the most recent completed response for the user
|
||||
on the survey instance given by asset_spec.
|
||||
|
||||
=cut
|
||||
|
||||
sub answeredX {
|
||||
my ( $asset_spec, $key ) = @_;
|
||||
|
||||
# See if $otherInstances already contains the external survey
|
||||
if (my $other_instance = $otherInstances->{$asset_spec}) {
|
||||
my $values = $other_instance->{values};
|
||||
my $answered = exists $values->{$key};
|
||||
$session->log->debug("answeredX($asset_spec, $key) returns [$answered]");
|
||||
return $answered;
|
||||
} else {
|
||||
# Throw an exception, triggering run() to resolve the external reference and re-run
|
||||
die( { other_instance => $asset_spec } );
|
||||
}
|
||||
}
|
||||
|
||||
=head2 tag ($name, [$value])
|
||||
|
||||
Mutator utility sub that gives expressions access to tag response values (and optionally set them).
|
||||
|
||||
=head3 $name
|
||||
|
||||
Name of tag whose value is returned.
|
||||
|
||||
=head3 $value (optional)
|
||||
|
||||
If provided, the tag is set to this value.
|
||||
|
||||
=cut
|
||||
|
||||
sub tag {
|
||||
my ($name, $value) = @_;
|
||||
if (defined $value) {
|
||||
$session->log->debug("Setting tag [$name] to [$value]");
|
||||
$tags->{$name} = $value;
|
||||
} else {
|
||||
$value = $tags->{$name};
|
||||
$session->log->debug("tag($name) resolves to [$value]");
|
||||
}
|
||||
return $value;
|
||||
}
|
||||
|
||||
=head2 tagX
|
||||
|
||||
Same as L<tag>, except that first argument is an asset spec (assetId or url), which must resolve
|
||||
to a valid survey instance. The sub is applied to the most recent completed response for the user
|
||||
on the survey instance given by asset_spec.
|
||||
|
||||
Note that it doesn't really make sense to try to set a tag on an external asset, so this sub
|
||||
is only an accessor.
|
||||
|
||||
=cut
|
||||
|
||||
sub tagX {
|
||||
my ( $asset_spec, $name ) = @_;
|
||||
|
||||
# See if $otherInstances already contains the external survey
|
||||
if (my $other_instance = $otherInstances->{$asset_spec}) {
|
||||
my $tags = $other_instance->{tags};
|
||||
|
||||
my $value = $tags->{$name};
|
||||
$session->log->debug("tagX($asset_spec, $name) returns [$value]");
|
||||
return $value;
|
||||
} else {
|
||||
# Throw an exception, triggering run() to resolve the external reference and re-run
|
||||
die( { other_instance => $asset_spec } );
|
||||
}
|
||||
}
|
||||
|
||||
=head2 jump
|
||||
|
||||
Utility sub shared with Safe compartment so that expressions can call individual jump tests.
|
||||
|
|
@ -144,7 +233,7 @@ catch the first successful jump.
|
|||
|
||||
sub jump(&$) {
|
||||
my ( $sub, $target ) = @_;
|
||||
$jump_count++;
|
||||
$jumpCount++;
|
||||
|
||||
# If $validTargets known, make sure target is valid
|
||||
if ( $validTargets && !exists $validTargets->{$target} ) {
|
||||
|
|
@ -158,11 +247,11 @@ sub jump(&$) {
|
|||
}
|
||||
|
||||
if ( $sub->() ) {
|
||||
$session->log->debug("jump call #$jump_count is truthy");
|
||||
$session->log->debug("jump call #$jumpCount is truthy");
|
||||
die( { jump => $target } );
|
||||
}
|
||||
else {
|
||||
$session->log->debug("jump call #$jump_count is falsey");
|
||||
$session->log->debug("jump call #$jumpCount is falsey");
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -247,8 +336,13 @@ sub run {
|
|||
= 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} );
|
||||
$session = $s;
|
||||
$values = $opts->{values} || {};
|
||||
$scores = $opts->{scores} || {};
|
||||
$jumpCount = 0;
|
||||
$validate = $opts->{validate};
|
||||
$validTargets = $opts->{validTargets};
|
||||
$tags = $opts->{tags} || {};
|
||||
|
||||
if ( !$session->config->get('enableSurveyExpressionEngine') ) {
|
||||
$session->log->debug('enableSurveyExpressionEngine config option disabled, skipping');
|
||||
|
|
@ -262,8 +356,13 @@ sub run {
|
|||
|
||||
# Share our utility subs with the compartment
|
||||
$compartment->share('&value');
|
||||
$compartment->share('&valueX');
|
||||
$compartment->share('&score');
|
||||
$compartment->share('&scoreX');
|
||||
$compartment->share('&answered');
|
||||
$compartment->share('&answeredX');
|
||||
$compartment->share('&tag');
|
||||
$compartment->share('&tagX');
|
||||
$compartment->share('&jump');
|
||||
$compartment->share('&avg');
|
||||
|
||||
|
|
@ -289,7 +388,7 @@ sub run {
|
|||
if ( ref $@ && ref $@ eq 'HASH' && $@->{jump} ) {
|
||||
my $jump = $@->{jump};
|
||||
$session->log->debug("Returning [$jump]");
|
||||
return $jump;
|
||||
return { jump => $jump, tags => $tags };
|
||||
}
|
||||
|
||||
# See if an unresolved external reference was encountered
|
||||
|
|
@ -337,11 +436,11 @@ sub run {
|
|||
return;
|
||||
}
|
||||
|
||||
$other_instances->{$asset_spec} = {
|
||||
values =>
|
||||
$asset->responseJSON( undef, $mostRecentlyCompletedResponseId )->responseValuesByVariableName,
|
||||
scores =>
|
||||
$asset->responseJSON( undef, $mostRecentlyCompletedResponseId )->responseScoresByVariableName,
|
||||
my $rJSON = $asset->responseJSON( undef, $mostRecentlyCompletedResponseId );
|
||||
$otherInstances->{$asset_spec} = {
|
||||
values => $rJSON->responseValuesByVariableName,
|
||||
scores => $rJSON->responseScoresByVariableName,
|
||||
tags => $rJSON->tags,
|
||||
};
|
||||
$session->log->debug("Successfully looked up asset: $assetId. Repeating reval.");
|
||||
redo REVAL;
|
||||
|
|
@ -350,11 +449,12 @@ sub run {
|
|||
# Log all other errors (for example compile errors from bad expressions)
|
||||
if ($@) {
|
||||
$session->log->error($@);
|
||||
return; # Return undef on failure
|
||||
}
|
||||
|
||||
# Return undef on failure
|
||||
return;
|
||||
# If we reach here, no jump was issued, meaning that we probably just processed an expression that did some tagging
|
||||
return { jump => undef, tags => $tags };
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
1;
|
||||
|
|
@ -89,6 +89,7 @@ sub new {
|
|||
questionsAnswered => 0,
|
||||
startTime => time(),
|
||||
surveyOrder => undef,
|
||||
tags => {},
|
||||
|
||||
# And then allow jsonData to override defaults and/or add other members
|
||||
%{$jsonData},
|
||||
|
|
@ -270,6 +271,30 @@ sub startTime {
|
|||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 tags ([ $tags ])
|
||||
|
||||
Mutator for the tags that have been applied to the response.
|
||||
Returns (and optionally sets) the value of tags.
|
||||
|
||||
=head3 $tags (optional)
|
||||
|
||||
If defined, sets $tags to the supplied hashref.
|
||||
|
||||
=cut
|
||||
|
||||
sub tags {
|
||||
my $self = shift;
|
||||
my ($tags) = validate_pos(@_, {type => HASHREF, optional => 1});
|
||||
|
||||
if ( $tags ) {
|
||||
$self->response->{tags} = $tags;
|
||||
}
|
||||
|
||||
return $self->response->{tags};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 surveyOrder
|
||||
|
||||
Accessor. Initialized on first access via L<"initSurveyOrder">.
|
||||
|
|
@ -424,8 +449,11 @@ 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.
|
||||
gotos are handled similarly as with terminalUrls. The last goto in the set of questions wins.
|
||||
|
||||
In contrast, all gotoExpressions are passed to the Expression Engine (in order of: Answer, Question, Section).
|
||||
Expressions are not guaranteed to trigger a jump, and thus we give every expression in turn a change to run.
|
||||
The first expression to trigger a jump will cause any remaining expressions to be skipped.
|
||||
|
||||
=cut
|
||||
|
||||
|
|
@ -443,7 +471,7 @@ sub recordResponses {
|
|||
my @questions = $self->nextQuestions();
|
||||
|
||||
#GOTO jumps in the Survey. Order of precedence is Answer, Question, then Section.
|
||||
my ($goto, $gotoExpression);
|
||||
my ($goto, $sectionExpression, $questionExpression, $answerExpression);
|
||||
|
||||
# Handle terminal Section..
|
||||
my $terminalUrl;
|
||||
|
|
@ -458,7 +486,7 @@ sub recordResponses {
|
|||
}
|
||||
# .. and also gotoExpressions..
|
||||
elsif ( $section->{gotoExpression} =~ /\w/ ) {
|
||||
$gotoExpression = $section->{gotoExpression};
|
||||
$sectionExpression = $section->{gotoExpression};
|
||||
}
|
||||
|
||||
# Handle empty Section..
|
||||
|
|
@ -485,7 +513,7 @@ sub recordResponses {
|
|||
}
|
||||
# .. and also gotoExpressions..
|
||||
elsif ( $question->{gotoExpression} =~ /\w/ ) {
|
||||
$gotoExpression = $question->{gotoExpression};
|
||||
$questionExpression = $question->{gotoExpression};
|
||||
}
|
||||
|
||||
# Record Question comment
|
||||
|
|
@ -539,7 +567,7 @@ sub recordResponses {
|
|||
|
||||
# .. and also gotoExpressions..
|
||||
elsif ( $answer->{gotoExpression} =~ /\w/ ) {
|
||||
$gotoExpression = $answer->{gotoExpression};
|
||||
$answerExpression = $answer->{gotoExpression};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
@ -557,17 +585,20 @@ sub recordResponses {
|
|||
|
||||
# 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
|
||||
|
||||
# Do any requested branching..
|
||||
$self->processGoto($goto) if ( defined $goto ); ## no critic
|
||||
$self->processExpression($answerExpression) if ( defined $answerExpression ); ## no critic
|
||||
$self->processExpression($questionExpression) if ( defined $questionExpression ); ## no critic
|
||||
$self->processExpression($sectionExpression) if ( defined $sectionExpression ); ## no critic
|
||||
|
||||
# Handle next logic Section..
|
||||
my $section = $self->nextResponseSection();
|
||||
if($section and $section->{logical}){
|
||||
return $self->recordResponses({});
|
||||
my $section = $self->nextResponseSection();
|
||||
if ( $section and $section->{logical} ) {
|
||||
return $self->recordResponses( {} );
|
||||
}
|
||||
}
|
||||
else {
|
||||
|
|
@ -649,33 +680,45 @@ sub processGoto {
|
|||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 processGotoExpression ( $gotoExpression )
|
||||
=head2 processExpression ( $expression )
|
||||
|
||||
Processes the given gotoExpression, and triggers a call to L<"processGoto"> if the expression
|
||||
indicates that we should branch.
|
||||
Processes a Survey expression using the Survey Expression Engine.
|
||||
|
||||
=head3 $gotoExpression
|
||||
If the expression returns tag data, this data is stored in the response (see L<tags>).
|
||||
|
||||
The gotoExpression. See L<WebGUI::Asset::Wobject::Survey::ExpressionEngine> for more info.
|
||||
If the expression returns a jump target, triggers a call to L<"processGoto">.
|
||||
|
||||
=head3 $expression
|
||||
|
||||
The expression. See L<WebGUI::Asset::Wobject::Survey::ExpressionEngine> for more info.
|
||||
|
||||
=cut
|
||||
|
||||
sub processGotoExpression {
|
||||
sub processExpression {
|
||||
my $self = shift;
|
||||
my ($expression) = validate_pos(@_, {type => SCALAR});
|
||||
|
||||
# Prepare the ingredients..
|
||||
my $values = $self->responseValuesByVariableName;
|
||||
my $scores = $self->responseScoresByVariableName;
|
||||
my $tags = $self->tags;
|
||||
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");
|
||||
if (my $result = $engine->run($self->session, $expression, { values => $values, scores => $scores, tags => $tags, validTargets => \%validTargets} ) ) {
|
||||
# Update tags
|
||||
if (my $tags = $result->{tags} ) {
|
||||
$self->tags( $tags );
|
||||
}
|
||||
|
||||
if (my $jump = $result->{jump}) {
|
||||
$self->session->log->debug("Jumping to [$jump]");
|
||||
$self->processGoto($jump);
|
||||
} else {
|
||||
$self->session->log->debug("No hits, falling through");
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
|
|
@ -916,9 +959,13 @@ sub nextQuestions {
|
|||
|
||||
# Get all of the existing question responses (so that we can do Section and Question [[var]] replacements
|
||||
my $responseValuesByVariableName = $self->responseValuesByVariableName( { useText => 1 } );
|
||||
my $tags = $self->tags;
|
||||
|
||||
# Merge values and tags hashes for processing [[var]] templated text
|
||||
my %templateValues = (%$responseValuesByVariableName, %$tags);
|
||||
|
||||
# Do text replacement
|
||||
$section->{text} = $self->getTemplatedText($section->{text}, $responseValuesByVariableName);
|
||||
$section->{text} = $self->getTemplatedText($section->{text}, \%templateValues);
|
||||
|
||||
# Collect all the questions to be shown on the next page..
|
||||
my @questions;
|
||||
|
|
@ -941,7 +988,7 @@ sub nextQuestions {
|
|||
my %questionCopy = %{$self->survey->question( $address )};
|
||||
|
||||
# Do text replacement
|
||||
$questionCopy{text} = $self->getTemplatedText($questionCopy{text}, $responseValuesByVariableName);
|
||||
$questionCopy{text} = $self->getTemplatedText($questionCopy{text}, \%templateValues);
|
||||
|
||||
# Add any extra fields we want..
|
||||
$questionCopy{id} = $self->questionId($sIndex, $qIndex);
|
||||
|
|
@ -953,7 +1000,7 @@ sub nextQuestions {
|
|||
my %answerCopy = %{ $self->survey->answer( [ $sIndex, $qIndex, $aIndex ] ) };
|
||||
|
||||
# Do text replacement
|
||||
$answerCopy{text} = $self->getTemplatedText($answerCopy{text}, $responseValuesByVariableName);
|
||||
$answerCopy{text} = $self->getTemplatedText($answerCopy{text}, \%templateValues);
|
||||
|
||||
# Add any extra fields we want..
|
||||
$answerCopy{id} = $self->answerId($sIndex, $qIndex, $aIndex);
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ my $session = WebGUI::Test->session;
|
|||
|
||||
#----------------------------------------------------------------------------
|
||||
# Tests
|
||||
my $tests = 42;
|
||||
my $tests = 49;
|
||||
plan tests => $tests + 1;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
|
@ -41,7 +41,7 @@ SKIP: {
|
|||
is( $e->run( $session, 'jump { 1 } target' ),
|
||||
undef, "Nothing happens unless we turn on enableSurveyExpressionEngine in config" );
|
||||
$session->config->set( 'enableSurveyExpressionEngine', 1 );
|
||||
is( $e->run( $session, 'jump { 1 } target' ), 'target', "..now we're in business!" );
|
||||
cmp_deeply( $e->run( $session, 'jump { 1 } target' ), { jump => 'target', tags => {} }, "..now we're in business!" );
|
||||
|
||||
my %values = (
|
||||
n => 5,
|
||||
|
|
@ -54,7 +54,7 @@ SKIP: {
|
|||
);
|
||||
|
||||
# These should all jump to 'target'
|
||||
my @should_pass = (
|
||||
my @should_jump = (
|
||||
q{jump { 1 } target},
|
||||
q{jump { return 1 } target},
|
||||
q{jump { "string" } target},
|
||||
|
|
@ -78,27 +78,38 @@ SKIP: {
|
|||
q{jump { answered(n) && !answered(X) } target}, # answered() works
|
||||
);
|
||||
|
||||
my @should_fail = (
|
||||
my @should_not_jump = (
|
||||
q{}, # empty
|
||||
q{ return }, # empty
|
||||
q{1}, # doesn't call jump
|
||||
q|{|, # doesn't compile
|
||||
q{blah-dee-blah-blah}, # rubbish expression
|
||||
q{jump {} target}, # empty anon sub to jump
|
||||
q{jump { 0 } target}, # false sub to jump
|
||||
q{jump { value(n) == 500 } target},
|
||||
q{jump { value(s1) eq 'blah' } target},
|
||||
);
|
||||
|
||||
my @should_fail = (
|
||||
q|{|, # doesn't compile
|
||||
q{jump { time } target}, # time and other opcodes not allowed
|
||||
);
|
||||
|
||||
for my $expr (@should_pass) {
|
||||
is( $e->run( $session, $expr, { values => \%values, scores => \%scores } ),
|
||||
'target', "\"$expr\" jumps as expected" );
|
||||
# These ones should have 'target' as the jump target
|
||||
for my $expr (@should_jump) {
|
||||
cmp_deeply( $e->run( $session, $expr, { values => \%values, scores => \%scores, tags => {} } ),
|
||||
{ jump => 'target', tags => {} }, "\"$expr\" jumps as expected" );
|
||||
}
|
||||
|
||||
# These ones should come back with an undefined jump target
|
||||
for my $expr (@should_not_jump) {
|
||||
cmp_deeply( $e->run( $session, $expr, { values => \%values, scores => \%scores, tags => {} } ),
|
||||
{ jump => undef, tags => {} }, "\"$expr\" does not jump" );
|
||||
}
|
||||
|
||||
# These ones should return undef (general failure to run)
|
||||
for my $expr (@should_fail) {
|
||||
is( $e->run( $session, $expr, { values => \%values, scores => \%scores } ),
|
||||
undef, "\"$expr\" fails as expected" );
|
||||
undef,, "\"$expr\" fails as expected" );
|
||||
}
|
||||
|
||||
$e->run( $session, q{jump {$x = value(s1); $x = 'X'} target}, { values => \%values } );
|
||||
|
|
@ -107,11 +118,44 @@ SKIP: {
|
|||
like( $e->run( $session, '{', { validate => 1 } ), qr/Missing right curly/, "Validation option works" );
|
||||
|
||||
# Check validTargets option
|
||||
is( $e->run( $session, q{jump {1} target}, { values => \%values, validTargets => { a => 1 } } ),
|
||||
undef, 'target is not valid' );
|
||||
is( $e->run( $session, q{jump {1} target}, { values => \%values, validTargets => { target => 1 } } ),
|
||||
'target', '..whereas now it is ok' );
|
||||
cmp_deeply( $e->run( $session, q{jump {1} target}, { values => \%values, validTargets => { a => 1 } } ),
|
||||
{ jump => undef, tags => {} }, 'target is not valid' );
|
||||
cmp_deeply( $e->run( $session, q{jump {1} target}, { values => \%values, validTargets => { target => 1 } } ),
|
||||
{ jump => 'target', tags => {} }, '..whereas now it is ok' );
|
||||
|
||||
# Try some tagging
|
||||
cmp_deeply(
|
||||
$e->run( $session, q{}, { values => \%values } ),
|
||||
{ jump => undef, tags => {} },
|
||||
'returns empty hash for tags by default'
|
||||
);
|
||||
|
||||
cmp_deeply(
|
||||
$e->run( $session, q{}, { values => \%values, tags => { a => 1 } } ),
|
||||
{ jump => undef, tags => { a => 1 } },
|
||||
'existing tag values survive'
|
||||
);
|
||||
cmp_deeply(
|
||||
$e->run( $session, q{ tag(a,2) }, { values => \%values, tags => { a => 1 } } ),
|
||||
{ jump => undef, tags => { a => 2 } },
|
||||
'..but can be changed'
|
||||
);
|
||||
cmp_deeply(
|
||||
$e->run( $session, q{ tag(b,1) }, { values => \%values, tags => { a => 1 } } ),
|
||||
{ jump => undef, tags => { a => 1, b => 1 } },
|
||||
'..and new values can be set'
|
||||
);
|
||||
cmp_deeply(
|
||||
$e->run( $session, q{ jump{ tag(a) == 'abc' } target }, { values => \%values, tags => { a => 'abc' } } ),
|
||||
{ jump => 'target', tags => { a => 'abc' } },
|
||||
'..tag value resolved by tag() with single arg'
|
||||
);
|
||||
cmp_deeply(
|
||||
$e->run( $session, q{ tag(a,xyz); jump{ tag(a) == 'xyz' } target }, { values => {a => 'def'}, tags => { a => 'abc' } } ),
|
||||
{ jump => 'target', tags => { a => 'xyz' } },
|
||||
'..overwritten tag value can be used too everything else'
|
||||
);
|
||||
|
||||
# Create a test user
|
||||
$user = WebGUI::User->new( $session, 'new' );
|
||||
WebGUI::Test->usersToDelete($user);
|
||||
|
|
@ -148,20 +192,23 @@ SKIP: {
|
|||
'0-0-0' => 'My ext_s0q0a0 answer',
|
||||
'0-1-0' => 'My ext_s0q1a0 answer',
|
||||
});
|
||||
$rJSON->processExpression(q{ tag(ext_tag, 199) });
|
||||
|
||||
# Remember to persist our changes..
|
||||
$survey->persistSurveyJSON();
|
||||
$survey->persistResponseJSON();
|
||||
$survey->surveyEnd;
|
||||
|
||||
is( $e->run( $session, qq{jump {value('$id', ext_s0q0) eq 'ext_s0q0a0'} target}, {userId => $user->userId} ),
|
||||
'target', 'external value resolves ok when id used' );
|
||||
is( $e->run( $session, qq{jump {value('$url', ext_s0q0) eq 'ext_s0q0a0'} target}, {userId => $user->userId} ),
|
||||
'target', 'external value resolves ok when url used' );
|
||||
is( $e->run( $session, qq{jump {score('$url', ext_s0q0) == 150} target}, {userId => $user->userId} ),
|
||||
'target', 'external score resolves ok too' );
|
||||
is( $e->run( $session, qq{jump {score('$url', ext_s0) == 200} target}, {userId => $user->userId} ),
|
||||
'target', 'external score section totals work too' );
|
||||
cmp_deeply( $e->run( $session, qq{jump {valueX('$id', ext_s0q0) eq 'ext_s0q0a0'} target}, {userId => $user->userId} ),
|
||||
{ jump => 'target', tags => {} }, 'external value resolves ok when id used' );
|
||||
cmp_deeply( $e->run( $session, qq{jump {valueX('$url', ext_s0q0) eq 'ext_s0q0a0'} target}, {userId => $user->userId} ),
|
||||
{ jump => 'target', tags => {} }, 'external value resolves ok when url used' );
|
||||
cmp_deeply( $e->run( $session, qq{jump {scoreX('$url', ext_s0q0) == 150} target}, {userId => $user->userId} ),
|
||||
{ jump => 'target', tags => {} }, 'external score resolves ok too' );
|
||||
cmp_deeply( $e->run( $session, qq{jump {scoreX('$url', ext_s0) == 200} target}, {userId => $user->userId} ),
|
||||
{ jump => 'target', tags => {} }, 'external score section totals work too' );
|
||||
cmp_deeply( $e->run( $session, qq{jump {tagX('$url', ext_tag) == 199} target}, {userId => $user->userId} ),
|
||||
{ jump => 'target', tags => {} }, 'external tag lookups work too' );
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ my $session = WebGUI::Test->session;
|
|||
|
||||
#----------------------------------------------------------------------------
|
||||
# Tests
|
||||
my $tests = 83;
|
||||
my $tests = 87;
|
||||
plan tests => $tests + 1;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
|
@ -346,7 +346,7 @@ cmp_deeply($rJSON->responseScoresByVariableName, { s1q0 => 100, s1q1 => 200, s1
|
|||
|
||||
####################################################
|
||||
#
|
||||
# processGotoExpression
|
||||
# processExpression
|
||||
#
|
||||
####################################################
|
||||
# Turn on the survey Expression Engine
|
||||
|
|
@ -378,64 +378,73 @@ $rJSON->recordResponses({
|
|||
|
||||
is($rJSON->nextResponse, 2, 'nextResponse at 2 (s0q1) after first response');
|
||||
|
||||
$rJSON->processGotoExpression('blah-dee-blah-blah {');
|
||||
$rJSON->processExpression('blah-dee-blah-blah {');
|
||||
is($rJSON->nextResponse, 2, '..unchanged after duff expression');
|
||||
|
||||
$rJSON->processGotoExpression('jump { value(s0q0) == 4} s1');
|
||||
$rJSON->processExpression('jump { value(s0q0) == 4} s1');
|
||||
is($rJSON->nextResponse, 2, '..unchanged after false expression');
|
||||
|
||||
$rJSON->processGotoExpression('jump { value(s0q0) == 4} s0; jump { value(s1q0) == 5} s1;');
|
||||
$rJSON->processExpression('jump { value(s0q0) == 4} s0; jump { value(s1q0) == 5} s1;');
|
||||
is($rJSON->nextResponse, 2, '..similarly for multi-statement false expression');
|
||||
|
||||
$rJSON->processGotoExpression('jump { value(s0q0) == 3} DUFF_TARGET');
|
||||
$rJSON->processExpression('jump { value(s0q0) == 3} DUFF_TARGET');
|
||||
is($rJSON->nextResponse, 2, '..similarly for expression with invalid target');
|
||||
|
||||
$rJSON->processGotoExpression('jump { value(s0q0) == 3} s1');
|
||||
$rJSON->processExpression('jump { value(s0q0) == 3} s1');
|
||||
is($rJSON->nextResponse, 3, 'jumps to index of first question in section');
|
||||
|
||||
$rJSON->processGotoExpression('jump { value(s0q0) == 3} s2');
|
||||
$rJSON->processExpression('jump { value(s0q0) == 3} s2');
|
||||
is($rJSON->nextResponse, 5, '..and updated to s2 with different jump target');
|
||||
|
||||
$rJSON->nextResponse(2); # pretend we just finished s0q2
|
||||
$rJSON->processGotoExpression('jump { value(s0q0) == 3} s3');
|
||||
$rJSON->processExpression('jump { value(s0q0) == 3} s3');
|
||||
is($rJSON->nextResponse, 6, '..and updated to s3 with different jump target');
|
||||
|
||||
$rJSON->nextResponse(2); # pretend we just finished s0q2
|
||||
$rJSON->processGotoExpression('jump { value(s0q0) == 3} s3q1');
|
||||
$rJSON->processExpression('jump { value(s0q0) == 3} s3q1');
|
||||
is($rJSON->nextResponse, 7, '..we can also jump to a question rather than a section');
|
||||
|
||||
$rJSON->nextResponse(2); # pretend we just finished s0q2
|
||||
$rJSON->processGotoExpression('jump { value(s0q0) == 3} NEXT_SECTION');
|
||||
$rJSON->processExpression('jump { value(s0q0) == 3} NEXT_SECTION');
|
||||
is($rJSON->nextResponse, 3, '..we can also use the NEXT_SECTION target');
|
||||
|
||||
$rJSON->lastResponse(3); # pretend we just finished s1q0
|
||||
$rJSON->processGotoExpression('jump { value(s0q0) == 3} NEXT_SECTION');
|
||||
$rJSON->processExpression('jump { value(s0q0) == 3} NEXT_SECTION');
|
||||
is($rJSON->nextResponse, 5, '..try that again from a different starting point');
|
||||
|
||||
$rJSON->lastResponse(8); # pretend we just finished s3q2
|
||||
$rJSON->processGotoExpression('jump { value(s0q0) == 3} NEXT_SECTION');
|
||||
$rJSON->processExpression('jump { value(s0q0) == 3} NEXT_SECTION');
|
||||
is($rJSON->nextResponse, 9, '..NEXT_SECTION on the last section is ok, it just ends the survey');
|
||||
|
||||
$rJSON->nextResponse(2); # pretend we just finished s0q2
|
||||
$rJSON->processGotoExpression('jump { value(s0q0) == 3} END_SURVEY');
|
||||
$rJSON->processExpression('jump { value(s0q0) == 3} END_SURVEY');
|
||||
is($rJSON->nextResponse, 9, '..we can also jump to end with END_SURVEY target');
|
||||
|
||||
$rJSON->nextResponse(2); # pretend we just finished s0q2
|
||||
$rJSON->processGotoExpression('jump { value(s0q0) == 4} s0; jump { value(s0q0) == 3} s1');
|
||||
$rJSON->processExpression('jump { value(s0q0) == 4} s0; jump { value(s0q0) == 3} s1');
|
||||
is($rJSON->nextResponse, 3, '..first true statement wins');
|
||||
|
||||
$rJSON->nextResponse(2); # pretend we just finished s0q2
|
||||
$rJSON->processGotoExpression('jump { score(s0q0) == 100} s1');
|
||||
$rJSON->processExpression('jump { score(s0q0) == 100} s1');
|
||||
is($rJSON->nextResponse, 3, '..and again when score used');
|
||||
|
||||
$rJSON->nextResponse(2); # pretend we just finished s0q2
|
||||
$rJSON->processGotoExpression('jump { score("s0") == 300} s1');
|
||||
$rJSON->processExpression('jump { score("s0") == 300} s1');
|
||||
is($rJSON->nextResponse, 3, '..and again when section score total used');
|
||||
|
||||
$rJSON->nextResponse(2); # pretend we just finished s0q2
|
||||
$rJSON->processGotoExpression('jump { answered(s0q0) && !answered(ABCDEFG) } s1');
|
||||
$rJSON->processExpression('jump { answered(s0q0) && !answered(ABCDEFG) } s1');
|
||||
is($rJSON->nextResponse, 3, '..and again when answered() used');
|
||||
|
||||
$rJSON->nextResponse(2); # pretend we just finished s0q2
|
||||
cmp_deeply($rJSON->tags, {}, 'No tag data');
|
||||
$rJSON->processExpression('tag(a,100)');
|
||||
cmp_deeply($rJSON->tags, { a => 100 }, 'Tag data set');
|
||||
$rJSON->processExpression('tag(b,50); jump {tag(a) + tag(b) == 150} s1');
|
||||
|
||||
cmp_deeply($rJSON->tags, { a => 100, b => 50 }, 'Tag data cumulative');
|
||||
is($rJSON->nextResponse, 3, '..and is useful for jump expressions');
|
||||
|
||||
$rJSON->responses({});
|
||||
$rJSON->questionsAnswered(-1 * $rJSON->questionsAnswered);
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue