Replaced Survey parseGotoExpression with dedicated ExpressionEngine.
Improved gotoExpression validation error reporting Added lots more tests
This commit is contained in:
Patrick Donelan
parent
83e7163f31
commit
9ea4f1cd20
5 changed files with 325 additions and 202 deletions
183
lib/WebGUI/Asset/Wobject/Survey/ExpressionEngine.pm
Normal file
183
lib/WebGUI/Asset/Wobject/Survey/ExpressionEngine.pm
Normal file
|
|
@ -0,0 +1,183 @@
|
|||
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 $vars;
|
||||
my $jump_count;
|
||||
my $validate;
|
||||
my $validTargets;
|
||||
|
||||
=head2 var
|
||||
|
||||
Utility sub shared with Safe compartment so that expressions can access allowed vars.
|
||||
|
||||
=cut
|
||||
|
||||
sub var($) {
|
||||
my $key = shift;
|
||||
my $value = $vars->{$key};
|
||||
$session->log->debug("[$key] resolves to [$value]");
|
||||
return $value; # 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 number of values
|
||||
|
||||
=cut
|
||||
|
||||
sub avg {
|
||||
my @vals = @_;
|
||||
return sum(@vals) / @vals;
|
||||
}
|
||||
|
||||
=head2 run ( $session, $expression, $opts )
|
||||
|
||||
Class method.
|
||||
|
||||
Evaluates the given expression in a Safe compartment, giving the expression access to vars.
|
||||
|
||||
=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 response values, the expression calls L<var>.
|
||||
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 { var(s1q1) == 0 } target
|
||||
|
||||
A more complicated gotoExpression with two possible jumps might look like:
|
||||
|
||||
jump { var('my_var') > 5 and var('my_var2') =~ m/textmatch/ } target1;
|
||||
jump { $avg = (var(q1) + var(q2) + var(q3)) / 3; return $avg > 10 } target2;
|
||||
|
||||
=head3 opts (optional)
|
||||
|
||||
Supported options are:
|
||||
|
||||
=over 3
|
||||
|
||||
=item * vars
|
||||
|
||||
Hashref of vars to make available to the expression via the L<var> utility sub
|
||||
|
||||
=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, $vars, $jump_count, $validate, $validTargets ) = ( $s, $opts->{vars}, 0, $opts->{validate}, $opts->{validTargets} );
|
||||
|
||||
# Create the Safe compartment
|
||||
my $compartment = Safe->new();
|
||||
|
||||
# Share our utility subs with the compartment
|
||||
$compartment->share('&var');
|
||||
$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;
|
||||
|
|
@ -649,64 +649,21 @@ 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 L<"processGoto">.
|
||||
|
||||
The expression should be valid perl. Any section/question variables that you refer to
|
||||
should be written as $var, as if your perl code had access to that variable. In reality,
|
||||
those variables don't exist - they're substituted in via L<parseGotoExpression> and
|
||||
then the expression is evaluated in a safe compartment.
|
||||
|
||||
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
|
||||
|
||||
You can do advanced branching by creating your own variables within the expression, for
|
||||
example, to branch when the average of 3 questions is greater than 5:
|
||||
S1: $avg = ($Q1 + $Q2 + $Q3) / 3; $avg > 5
|
||||
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 $responsesByVariableName = $self->responsesByVariableName();
|
||||
|
||||
# Parse gotoExpressions one after the other (first one that's true wins)
|
||||
foreach my $line (split /\n/, $expression) {
|
||||
my $processed = WebGUI::Asset::Wobject::Survey::ResponseJSON->parseGotoExpression($self->session, $line, $responsesByVariableName);
|
||||
|
||||
next if !$processed;
|
||||
|
||||
# Eval expression in a safe compartment
|
||||
# N.B. Expression does not need access to any variables
|
||||
my $compartment = Safe->new();
|
||||
my $result = $compartment->reval($processed->{expression});
|
||||
|
||||
$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;
|
||||
}
|
||||
|
||||
use WebGUI::Asset::Wobject::Survey::ExpressionEngine;
|
||||
my $engine = "WebGUI::Asset::Wobject::Survey::ExpressionEngine";
|
||||
if (my $jump = $engine->run($self->session, $expression, { vars => $self->responsesByVariableName} )) {
|
||||
$self->session->log->debug("Hit. Jumping to [$jump]");
|
||||
$self->processGoto($jump);
|
||||
}
|
||||
$self->session->log->debug("No hits, falling through");
|
||||
return;
|
||||
}
|
||||
|
||||
|
|
@ -788,66 +745,6 @@ sub responsesByVariableName {
|
|||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 parseGotoExpression( ( $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)
|
||||
|
||||
=cut
|
||||
|
||||
sub parseGotoExpression {
|
||||
my $class = shift;
|
||||
my ($session, $expression, $responses) = validate_pos(@_, { isa => 'WebGUI::Session'}, { type => SCALAR }, { type => HASHREF, default => {} });
|
||||
|
||||
$session->log->debug("Parsing gotoExpression: $expression");
|
||||
|
||||
my ( $target, $rest ) = $expression =~ /\s* ([^:]+?) \s* : \s* (.*)/x;
|
||||
|
||||
$session->log->debug("Parsed as Target: [$target], Expression: [$rest]");
|
||||
|
||||
if ( !defined $target ) {
|
||||
$session->log->warn('Target undefined');
|
||||
return;
|
||||
}
|
||||
|
||||
if ( !defined $rest || $rest eq q{} ) {
|
||||
$session->log->warn('Expression undefined');
|
||||
return;
|
||||
}
|
||||
|
||||
# Replace each "$questionName" with its response value
|
||||
while ( my ( $questionName, $response ) = each %{$responses} ) {
|
||||
$rest =~ s/\$$questionName/$response/g;
|
||||
}
|
||||
|
||||
$session->log->debug("Processed as: $rest");
|
||||
|
||||
return {
|
||||
target => $target,
|
||||
expression => $rest,
|
||||
};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getTemplatedText ($text, $responses)
|
||||
|
||||
Scans a string of text for instances of "[[var]]". Looks up each match in the given hash reference
|
||||
|
|
|
|||
|
|
@ -1222,13 +1222,13 @@ sub validateSurvey{
|
|||
my $sNum = $s + 1;
|
||||
my $section = $self->section([$s]);
|
||||
if(! $self->validateGoto($section,$goodTargets)){
|
||||
push @messages,"Section $sNum has invalid Jump target: $section->{goto}";
|
||||
push @messages,"Section $sNum has invalid Jump target: \"$section->{goto}\"";
|
||||
}
|
||||
if(! $self->validateGotoInfiniteLoop($section)){
|
||||
push(@messages,"Section $sNum jumps to itself.");
|
||||
push @messages,"Section $sNum jumps to itself.";
|
||||
}
|
||||
if(! $self->validateGotoExpression($section,$goodTargets)){
|
||||
push(@messages,"Section $sNum has invalid Jump Expression: $section->{gotoExpression}");
|
||||
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}) {
|
||||
|
|
@ -1242,19 +1242,19 @@ sub validateSurvey{
|
|||
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}");
|
||||
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.");
|
||||
push @messages,"Section $sNum Question $qNum jumps to itself.";
|
||||
}
|
||||
if(! $self->validateGotoExpression($question,$goodTargets)){
|
||||
push(@messages,"Section $sNum Question $qNum has invalid Jump Expression: $question->{gotoExpression}");
|
||||
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.");
|
||||
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.");
|
||||
push @messages,"Section $sNum Question $qNum does not have any text.";
|
||||
}
|
||||
if (my $var = $question->{variable}) {
|
||||
if (my $count = $duplicateTargets->{$var}) {
|
||||
|
|
@ -1268,13 +1268,13 @@ sub validateSurvey{
|
|||
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}");
|
||||
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.");
|
||||
push @messages,"Section $sNum Question $qNum Answer $aNum jumps to itself.";
|
||||
}
|
||||
if(! $self->validateGotoExpression($answer,$goodTargets)){
|
||||
push(@messages,"Section $sNum Question $qNum Answer $aNum has invalid Jump Expression: $answer->{gotoExpression}");
|
||||
if(my $error = $self->validateGotoExpression($answer,$goodTargets)){
|
||||
push @messages,"Section $sNum Question $qNum Answer $aNum has invalid Jump Expression: \"$answer->{gotoExpression}\". Error: $error";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
@ -1301,10 +1301,12 @@ sub validateGotoInfiniteLoop{
|
|||
sub validateGotoExpression{
|
||||
my $self = shift;
|
||||
my $object = shift;
|
||||
return 1 unless $object->{gotoExpression} =~ /\w/;
|
||||
my $goodTargets = shift;
|
||||
return unless $object->{gotoExpression};
|
||||
|
||||
# The best we can do is return true/false on whether the gotoExpression parses
|
||||
return WebGUI::Asset::Wobject::Survey::ResponseJSON->parseGotoExpression($self->session, $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)
|
||||
|
|
|
|||
102
t/Asset/Wobject/Survey/ExpressionEngine.t
Normal file
102
t/Asset/Wobject/Survey/ExpressionEngine.t
Normal file
|
|
@ -0,0 +1,102 @@
|
|||
# Tests WebGUI::Asset::Wobject::Survey
|
||||
#
|
||||
#
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use FindBin;
|
||||
use lib "$FindBin::Bin/../../../lib";
|
||||
use Test::More;
|
||||
use Test::Deep;
|
||||
use Test::MockObject::Extends;
|
||||
use Test::Exception;
|
||||
use Data::Dumper;
|
||||
use List::Util qw/shuffle/;
|
||||
use WebGUI::Test; # Must use this before any other WebGUI modules
|
||||
use WebGUI::Session;
|
||||
use Tie::IxHash;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# Init
|
||||
my $session = WebGUI::Test->session;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# Tests
|
||||
my $tests = 33;
|
||||
plan tests => $tests + 1;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# put your tests here
|
||||
|
||||
my $usedOk = use_ok('WebGUI::Asset::Wobject::Survey::ExpressionEngine');
|
||||
|
||||
SKIP: {
|
||||
|
||||
skip $tests, "Unable to load ExpressionEngine" unless $usedOk;
|
||||
|
||||
my $e = "WebGUI::Asset::Wobject::Survey::ExpressionEngine";
|
||||
|
||||
my %vars = (
|
||||
n => 5,
|
||||
s1 => 'my string',
|
||||
);
|
||||
|
||||
# These should all jump to 'target'
|
||||
my @should_pass = (
|
||||
q{jump { 1 } target},
|
||||
q{jump { return 1 } target},
|
||||
q{jump { "string" } target},
|
||||
q{jump { var(n) == 5 } target},
|
||||
q{jump { var(n) > 0 } target},
|
||||
q{jump { var(s1) eq "my string" } target},
|
||||
q{jump { var(s1) =~ m/my/ } target},
|
||||
q{jump { var(n) == 4 or var(n) == 5 } target},
|
||||
q{jump { var(n) == 5 && var(n) > 0 } target},
|
||||
q{jump { (var(n) > 1 ? 10 : 11) == 10 } target},
|
||||
q{jump { $a=1; $a++; $a++; $a *= 2; $a == 6 } target},
|
||||
q{jump { @a = (1..10); $a[0] == 1 && @a == 10 } target}, # arrays
|
||||
q{jump { if (var(n) == 5) { 1 } else { 0 } } target}, # if statement
|
||||
q{jump { $q2 = 3; $avg = (var(n) + $q2) / 2; $avg == 4 } target}, # look ma, averages!
|
||||
q{jump { $q2 = 3; avg(var(n), $q2) == 4 } target}, # look ma, built-in avg sub!
|
||||
q{jump { var(n) == 5 } target; jump { var(n) == 5 } targetX}, # first jump wins
|
||||
q{jump { var(n) == 0 } targetX; jump { var(n) == 5 } target}, # false jumps ignored
|
||||
q{jump { min(3,5,2) == 2 } target}, # List::Util min
|
||||
q{jump { sum(var(n),1,1,1) == 8 } target}, # List::Util sum, etc..
|
||||
);
|
||||
|
||||
my @should_fail = (
|
||||
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 { var(n) == 500 } target},
|
||||
q{jump { var(s1) eq 'blah' } target},
|
||||
q{jump { time } target}, # time and other opcodes not allowed
|
||||
);
|
||||
|
||||
for my $expr (@should_pass) {
|
||||
is( $e->run( $session, $expr, { vars => \%vars } ), 'target', "\"$expr\" jumps as expected" );
|
||||
}
|
||||
|
||||
for my $expr (@should_fail) {
|
||||
is( $e->run( $session, $expr, { vars => \%vars } ), undef, "\"$expr\" fails as expected" );
|
||||
}
|
||||
|
||||
$e->run( $session, q{jump {$x = var(s1); $x = 'X'} target}, { vars => \%vars } );
|
||||
is( $vars{s1}, 'my string', "Expression can't modify vars" );
|
||||
|
||||
like( $e->run( $session, '{', { validate => 1 } ), qr/Missing right curly/, "Validation option works" );
|
||||
|
||||
# Check validTargets option
|
||||
is( $e->run( $session, q{jump {1} target}, { vars => \%vars, validTargets => { a => 1 } } ),
|
||||
undef, 'target is not valid' );
|
||||
is( $e->run( $session, q{jump {1} target}, { vars => \%vars, validTargets => { target => 1 } } ),
|
||||
'target', '..whereas now it is ok' );
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# Cleanup
|
||||
END { }
|
||||
|
|
@ -22,7 +22,7 @@ my $session = WebGUI::Test->session;
|
|||
|
||||
#----------------------------------------------------------------------------
|
||||
# Tests
|
||||
my $tests = 91;
|
||||
my $tests = 59;
|
||||
plan tests => $tests + 1;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
|
@ -321,36 +321,6 @@ is($rJSON->lastResponse(), 0, 'goto: works on existing question');
|
|||
$rJSON->processGoto('goto 3-0');
|
||||
is($rJSON->lastResponse(), 5, 'goto: finds first if there are duplicates');
|
||||
|
||||
####################################################
|
||||
#
|
||||
# parseGotoExpression
|
||||
#
|
||||
####################################################
|
||||
my $c = 'WebGUI::Asset::Wobject::Survey::ResponseJSON';
|
||||
throws_ok { $c->parseGotoExpression($session, ) } 'WebGUI::Error::InvalidParam', 'processGotoExpression takes exception to empty arguments';
|
||||
is($c->parseGotoExpression($session, q{}),
|
||||
undef, '.. and undef with empty expression');
|
||||
is($c->parseGotoExpression($session, 'blah-dee-blah-blah'),
|
||||
undef, '.. and undef with duff expression');
|
||||
is($c->parseGotoExpression($session, ':'),
|
||||
undef, '.. and undef with missing target');
|
||||
is($c->parseGotoExpression($session, 't1:'),
|
||||
undef, '.. and undef with missing expression');
|
||||
cmp_deeply($c->parseGotoExpression($session, 't1: 1'),
|
||||
{ target => 't1', expression => '1'}, 'works for simple numeric expression');
|
||||
cmp_deeply($c->parseGotoExpression($session, 't1: 1 - 23 + 456 * (78 / 9.0)'),
|
||||
{ target => 't1', expression => '1 - 23 + 456 * (78 / 9.0)'}, 'works for expression using all algebraic tokens');
|
||||
cmp_deeply($c->parseGotoExpression($session, 't1: 1 != 3 <= 4 >= 5'),
|
||||
{ target => 't1', expression => '1 != 3 <= 4 >= 5'}, q{..works with other ops too});
|
||||
cmp_deeply($c->parseGotoExpression($session, 't1: $q1 + $q2 * $q3 - 4', { q1 => 11, q2 => 22, q3 => 33}),
|
||||
{ target => 't1', expression => '11 + 22 * 33 - 4'}, 'substitues q for value');
|
||||
cmp_deeply($c->parseGotoExpression($session, 't1: $a silly var name * 10 + $another var name', { 'a silly var name' => 345, 'another var name' => 456}),
|
||||
{ target => 't1', expression => '345 * 10 + 456'}, '..it even works for vars with spaces in their names');
|
||||
cmp_deeply($c->parseGotoExpression($session, 't1: ($A < 4) and ($B < 4) or ($B > 6) && 1 || 1', { A => 2, B => 3}),
|
||||
{ target => 't1', expression => '(2 < 4) and (3 < 4) or (3 > 6) && 1 || 1'}, 'Boolean expressions ok');
|
||||
cmp_deeply($c->parseGotoExpression($session, 't1: $a = 1; $a++; $a > 1'),
|
||||
{ target => 't1', expression => '$a = 1; $a++; $a > 1'}, 'Assignment and compound statements ok too');
|
||||
|
||||
####################################################
|
||||
#
|
||||
# processGotoExpression
|
||||
|
|
@ -368,53 +338,22 @@ $rJSON->recordResponses({
|
|||
'1-0-0' => 'My chosen answer',
|
||||
'1-0-0comment' => 'Section 1, question 0, answer 0 comment',
|
||||
});
|
||||
is($rJSON->processGotoExpression('blah-dee-blah-blah'), undef, 'invalid gotoExpression is false');
|
||||
ok($rJSON->processGotoExpression('s0: $s1q0 == 3'), '3 == 3 is true');
|
||||
ok(!$rJSON->processGotoExpression('s0: $s1q0 == 4'), '3 == 4 is false');
|
||||
ok($rJSON->processGotoExpression('s0: $s1q0 != 2'), '3 != 2 is true');
|
||||
ok(!$rJSON->processGotoExpression('s0: $s1q0 != 3'), '3 != 3 is false');
|
||||
ok($rJSON->processGotoExpression('s0: $s1q0 > 2'), '3 > 2 is true');
|
||||
ok($rJSON->processGotoExpression('s0: $s1q0 < 4'), '3 < 2 is true');
|
||||
ok(!$rJSON->processGotoExpression('s0: $s1q0 >= 4'), '3 >= 4 is false');
|
||||
ok(!$rJSON->processGotoExpression('s0: $s1q0 <= 2'), '3 <= 2 is false');
|
||||
ok(!$rJSON->processGotoExpression('s0: $s1q0 < 2 or $s1q0 < 1'), '3 < 2 || 3 < 1 is false');
|
||||
ok($rJSON->processGotoExpression('s0: $s1q0 < 2 or $s1q0 < 5'), '3 < 2 || 3 < 5 is true');
|
||||
ok(!$rJSON->processGotoExpression('s0: $s1q0 == 4 and 1 == 1'), '3 == 4 && 1 == 1 is false');
|
||||
ok($rJSON->processGotoExpression('s0: $s1q0 == 3 and 1 == 1'), '3 == 3 && 1 == 1 is true');
|
||||
ok(!$rJSON->processGotoExpression('s0: ($s1q0 > 1 ? 10 : 11) == 11'), '(3 > 1 ? 10 : 11) == 11 is false');
|
||||
ok($rJSON->processGotoExpression('s0: ($s1q0 > 1 ? 10 : 11) == 10'), '(3 > 1 ? 10 : 11) == 10 is true');
|
||||
ok($rJSON->processGotoExpression('s0: $a=1; $a++; $a++; $a *= 2; $a == 6'), 'Assignment and compound statements ok');
|
||||
ok(!$rJSON->processGotoExpression('s0: $a=1; $a++; $a++; $a *= 2; $a == 7'), '..negative ones too');
|
||||
ok($rJSON->processGotoExpression('s0: @a = (1..10); $a[0] == 1 && @a == 10'), 'arrays work too');
|
||||
ok($rJSON->processGotoExpression('s0: if ($s1q0 == 3) { 1 } else { 0 }'), 'if statements work');
|
||||
ok(!$rJSON->processGotoExpression('s0: if (time) { 1 } else { 1 }'), 'time and other things not allowed');
|
||||
ok($rJSON->processGotoExpression('s0: $q2 = 5; $avg = ($s1q0 + $q2) / 2; $avg == 4'), 'look ma, averages!');
|
||||
is($rJSON->lastResponse, 4, 'lastResponse at 4 before any gotoExpressions processed');
|
||||
|
||||
cmp_deeply($rJSON->processGotoExpression(<<'END_EXPRESSION'), {target => 's2', expression => '3 == 3'}, 'first true expression wins');
|
||||
s0: $s1q0 <= 2
|
||||
s2: $s1q0 == 3
|
||||
END_EXPRESSION
|
||||
$rJSON->processGotoExpression('blah-dee-blah-blah {');
|
||||
is($rJSON->lastResponse, 4, '..unchanged after duff expression');
|
||||
|
||||
ok(!$rJSON->processGotoExpression(<<'END_EXPRESSION'), 'but multiple false expressions still false');
|
||||
s0: $s1q0 <= 2
|
||||
s2: $s1q0 == 345
|
||||
END_EXPRESSION
|
||||
$rJSON->processGotoExpression('jump { var(s1q0) == 4} s0');
|
||||
is($rJSON->lastResponse, 4, '..unchanged after false expression');
|
||||
|
||||
$rJSON->processGotoExpression('s0: $s1q0 == 3');
|
||||
is($rJSON->lastResponse(), -1, '.. lastResponse changed to -1 due to processGoto(s0)');
|
||||
$rJSON->processGotoExpression('s2: $s1q0 == 3');
|
||||
is($rJSON->lastResponse(), 4, '.. lastResponse changed to 4 due to processGoto(s2)');
|
||||
$rJSON->processGotoExpression('jump { var(s1q0) == 4} s0; jump { var(s1q0) == 5} s0;');
|
||||
is($rJSON->lastResponse, 4, '..similarly for multi-statement false expression');
|
||||
|
||||
$rJSON->survey->question([1,0])->{questionType} = 'Text';
|
||||
$rJSON->lastResponse(2);
|
||||
$rJSON->recordResponses({
|
||||
'1-0-0' => 'My text answer',
|
||||
});
|
||||
is( $rJSON->responses->{'1-0-0'}->{value}, 'My text answer', 'Text type uses entered text' );
|
||||
$rJSON->processGotoExpression('jump { var(s1q0) == 3} s0');
|
||||
is($rJSON->lastResponse, -1, '..but updated to s0 after true expression');
|
||||
|
||||
# Coming soon.
|
||||
#ok($rJSON->processGotoExpression('s0: $s1q0 eq "Text answer"; print "hola!\n"'), 'text match');
|
||||
#ok(!$rJSON->processGotoExpression('s0: $s1q0 eq "Not the right text answer"'), 'negative text match');
|
||||
$rJSON->processGotoExpression('jump { var(s1q0) == 4} s0; jump { var(s1q0) == 3} s2');
|
||||
is($rJSON->lastResponse, 4, '..changed again for multi-statement true expression');
|
||||
|
||||
$rJSON->responses({});
|
||||
$rJSON->questionsAnswered(-1 * $rJSON->questionsAnswered);
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue