Made Survey ExpressionEngine disabled by default, controlled via config

file enableSurveyExpressionEngine flag
Added branching based on question score and section score total
Added more tests
This commit is contained in:
Patrick Donelan 2009-04-08 08:12:44 +00:00
parent 9ea4f1cd20
commit a7cb9b031d
5 changed files with 211 additions and 63 deletions

View file

@ -33,6 +33,7 @@ my $session = start(); # this line required
# upgrade functions go here
addSurveyQuizModeColumns($session);
addSurveyExpressionEngineConfigFlag($session);
finish($session); # this line required
@ -54,6 +55,13 @@ sub addSurveyQuizModeColumns{
print "Done.\n" unless $quiet;
}
sub addSurveyExpressionEngineConfigFlag{
my $session = shift;
print "\tAdding enableSurveyExpressionEngine config option... " unless $quiet;
$session->config->set('enableSurveyExpressionEngine', 0);
print "Done.\n" unless $quiet;
}
# -------------- DO NOT EDIT BELOW THIS LINE --------------------------------
#----------------------------------------------------------------------------

View file

@ -22,24 +22,43 @@ Params::Validate::validation_options( on_fail => sub { WebGUI::Error::InvalidPar
# 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 $values;
my $scores;
my $jump_count;
my $validate;
my $validTargets;
=head2 var
=head2 value
Utility sub shared with Safe compartment so that expressions can access allowed vars.
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 var($) {
sub value($) {
my $key = shift;
my $value = $vars->{$key};
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.
@ -74,8 +93,7 @@ sub jump(&$) {
=head2 avg
Utility sub shared with Safe compartment to allows expressions to easily compute the average
of a number of values
Utility sub shared with Safe compartment to allows expressions to easily compute the average of a list
=cut
@ -88,7 +106,7 @@ sub avg {
Class method.
Evaluates the given expression in a Safe compartment, giving the expression access to vars.
Evaluates the given expression in a Safe compartment.
=head3 session
@ -100,19 +118,20 @@ 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 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 { var(s1q1) == 0 } target
jump { value(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;
jump { value(q1) > 5 and value(s2q1) =~ m/textmatch/ } target1;
jump { avg(value(q1), value(q2), value(q3)) > 10 } target2;
=head3 opts (optional)
@ -120,9 +139,18 @@ Supported options are:
=over 3
=item * vars
=item * values
Hashref of vars to make available to the expression via the L<var> utility sub
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
@ -138,13 +166,19 @@ sub run {
= 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} );
( $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('&var');
$compartment->share('&value');
$compartment->share('&score');
$compartment->share('&jump');
$compartment->share('&avg');

View file

@ -657,9 +657,14 @@ sub processGotoExpression {
my $self = shift;
my ($expression) = validate_pos(@_, {type => SCALAR});
# Prepare the ingredients..
my $values = $self->responseValuesByVariableName;
my $scores = $self->responseScoresByVariableName;
my %validTargets = map { $_ => 1 } @{$self->survey->getGotoTargets};
use WebGUI::Asset::Wobject::Survey::ExpressionEngine;
my $engine = "WebGUI::Asset::Wobject::Survey::ExpressionEngine";
if (my $jump = $engine->run($self->session, $expression, { vars => $self->responsesByVariableName} )) {
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);
}
@ -709,7 +714,7 @@ sub recordedResponses{
#-------------------------------------------------------------------
=head2 responsesByVariableName
=head2 responseValuesByVariableName
Returns a lookup table to question variable names and recorded response values.
@ -718,7 +723,7 @@ the L<responses> hash.
=cut
sub responsesByVariableName {
sub responseValuesByVariableName {
my $self = shift;
my %lookup;
@ -745,6 +750,59 @@ sub responsesByVariableName {
#-------------------------------------------------------------------
=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};
}
# Add section score totals
for my $s (@{$self->survey->sections}) {
next unless $s->{variable};
my $score = 0;
for my $q (@{$s->{questions}}) {
next unless $q->{variable};
next unless exists $lookup{$q->{variable}};
$lookup{$s->{variable}} += $lookup{$q->{variable}};
}
}
return \%lookup;
}
#-------------------------------------------------------------------
=head2 getTemplatedText ($text, $responses)
Scans a string of text for instances of "[[var]]". Looks up each match in the given hash reference
@ -818,10 +876,10 @@ sub nextQuestions {
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 $responsesByVariableName = $self->responsesByVariableName();
my $responseValuesByVariableName = $self->responseValuesByVariableName();
# Do text replacement
$section->{text} = $self->getTemplatedText($section->{text}, $responsesByVariableName);
$section->{text} = $self->getTemplatedText($section->{text}, $responseValuesByVariableName);
# Collect all the questions to be shown on the next page..
my @questions;
@ -844,7 +902,7 @@ sub nextQuestions {
my %questionCopy = %{$self->survey->question( $address )};
# Do text replacement
$questionCopy{text} = $self->getTemplatedText($questionCopy{text}, $responsesByVariableName);
$questionCopy{text} = $self->getTemplatedText($questionCopy{text}, $responseValuesByVariableName);
# Add any extra fields we want..
$questionCopy{id} = $self->questionId($sIndex, $qIndex);
@ -856,7 +914,7 @@ sub nextQuestions {
my %answerCopy = %{ $self->survey->answer( [ $sIndex, $qIndex, $aIndex ] ) };
# Do text replacement
$answerCopy{text} = $self->getTemplatedText($answerCopy{text}, $responsesByVariableName);
$answerCopy{text} = $self->getTemplatedText($answerCopy{text}, $responseValuesByVariableName);
# Add any extra fields we want..
$answerCopy{id} = $self->answerId($sIndex, $qIndex, $aIndex);
@ -1107,7 +1165,7 @@ recorded value, and the id of the answer.
=cut
# TODO: This sub should make use of responsesByVariableName
# TODO: This sub should make use of responseValuesByVariableName
sub returnResponseForReporting {
my $self = shift;

View file

@ -22,7 +22,7 @@ my $session = WebGUI::Test->session;
#----------------------------------------------------------------------------
# Tests
my $tests = 33;
my $tests = 36;
plan tests => $tests + 1;
#----------------------------------------------------------------------------
@ -36,64 +36,78 @@ SKIP: {
my $e = "WebGUI::Asset::Wobject::Survey::ExpressionEngine";
my %vars = (
is( $e->run( $session, 'jump { 1 } target' ),
undef, "Nothing happens unless we turn on enableSurveyExpressionEngine in config" );
WebGUI::Test->originalConfig('enableSurveyExpressionEngine');
$session->config->set( 'enableSurveyExpressionEngine', 1 );
is( $e->run( $session, 'jump { 1 } target' ), 'target', "..now we're in business!" );
my %values = (
n => 5,
s1 => 'my string',
);
my %scores = (
n1 => 1,
n2 => 2,
);
# 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 { value(n) == 5 } target},
q{jump { value(n) > 0 } target},
q{jump { value(s1) eq "my string" } target},
q{jump { value(s1) =~ m/my/ } target},
q{jump { value(n) == 4 or value(n) == 5 } target},
q{jump { value(n) == 5 && value(n) > 0 } target},
q{jump { (value(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..
q{jump { @a = (1..10); $a[0] == 1 && @a == 10 } target}, # arrays
q{jump { if (value(n) == 5) { 1 } else { 0 } } target}, # if statement
q{jump { $q2 = 3; $avg = (value(n) + $q2) / 2; $avg == 4 } target}, # look ma, averages!
q{jump { $q2 = 3; avg(value(n), $q2) == 4 } target}, # look ma, built-in avg sub!
q{jump { value(n) == 5 } target; jump { value(n) == 5 } targetX}, # first jump wins
q{jump { value(n) == 0 } targetX; jump { value(n) == 5 } target}, # false jumps ignored
q{jump { min(3,5,2) == 2 } target}, # List::Util min
q{jump { sum(value(n),1,1,1) == 8 } target}, # List::Util sum, etc..
q{jump { score(n1) == 1 && score(n2) == 2 } target}, # score() works
);
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
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},
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" );
is( $e->run( $session, $expr, { values => \%values, scores => \%scores } ),
'target', "\"$expr\" jumps as expected" );
}
for my $expr (@should_fail) {
is( $e->run( $session, $expr, { vars => \%vars } ), undef, "\"$expr\" fails as expected" );
is( $e->run( $session, $expr, { values => \%values, scores => \%scores } ),
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" );
$e->run( $session, q{jump {$x = value(s1); $x = 'X'} target}, { values => \%values } );
is( $values{s1}, 'my string', "Expression can't modify values" );
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 } } ),
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}, { vars => \%vars, validTargets => { target => 1 } } ),
is( $e->run( $session, q{jump {1} target}, { values => \%values, validTargets => { target => 1 } } ),
'target', '..whereas now it is ok' );
}

View file

@ -22,7 +22,7 @@ my $session = WebGUI::Test->session;
#----------------------------------------------------------------------------
# Tests
my $tests = 59;
my $tests = 64;
plan tests => $tests + 1;
#----------------------------------------------------------------------------
@ -323,10 +323,35 @@ is($rJSON->lastResponse(), 5, 'goto: finds first if there are duplicates');
####################################################
#
# processGotoExpression
# responseScoresByVariableName
#
####################################################
$rJSON->survey->section([0])->{variable} = 's0';
$rJSON->survey->section([1])->{variable} = 's1';
$rJSON->survey->section([2])->{variable} = 's2';
$rJSON->survey->section([3])->{variable} = 's3';
$rJSON->survey->question([1,0])->{variable} = 's1q0';
$rJSON->survey->question([1,1])->{variable} = 's1q1';
$rJSON->survey->answer([1,0,0])->{value} = 100; # set answer score
$rJSON->survey->answer([1,1,0])->{value} = 200; # set answer score
cmp_deeply($rJSON->responseScoresByVariableName, {}, 'scores initially empty');
$rJSON->lastResponse(2);
$rJSON->recordResponses({
'1-0-0' => 'My chosen answer',
'1-1-0' => 'My chosen answer',
});
cmp_deeply($rJSON->responseScoresByVariableName, { s1q0 => 100, s1q1 => 200, s1 => 300}, 'scores now reflect q answers and section totals');
####################################################
#
# processGotoExpression
#
####################################################
# Turn on the survey Expression Engine
WebGUI::Test->originalConfig('enableSurveyExpressionEngine');
$session->config->set('enableSurveyExpressionEngine', 1);
$rJSON->survey->section([0])->{variable} = 's0'; # our first test jump target
$rJSON->survey->section([2])->{variable} = 's2'; # our second test jump target
$rJSON->survey->question([1,0])->{variable} = 's1q0'; # a question variable to use in our expressions
@ -343,18 +368,27 @@ is($rJSON->lastResponse, 4, 'lastResponse at 4 before any gotoExpressions proces
$rJSON->processGotoExpression('blah-dee-blah-blah {');
is($rJSON->lastResponse, 4, '..unchanged after duff expression');
$rJSON->processGotoExpression('jump { var(s1q0) == 4} s0');
$rJSON->processGotoExpression('jump { value(s1q0) == 4} s0');
is($rJSON->lastResponse, 4, '..unchanged after false expression');
$rJSON->processGotoExpression('jump { var(s1q0) == 4} s0; jump { var(s1q0) == 5} s0;');
$rJSON->processGotoExpression('jump { value(s1q0) == 4} s0; jump { value(s1q0) == 5} s0;');
is($rJSON->lastResponse, 4, '..similarly for multi-statement false expression');
$rJSON->processGotoExpression('jump { var(s1q0) == 3} s0');
$rJSON->processGotoExpression('jump { value(s1q0) == 3} DUFF_TARGET');
is($rJSON->lastResponse, 4, '..similarly for expression with invalid target');
$rJSON->processGotoExpression('jump { value(s1q0) == 3} s0');
is($rJSON->lastResponse, -1, '..but updated to s0 after true expression');
$rJSON->processGotoExpression('jump { var(s1q0) == 4} s0; jump { var(s1q0) == 3} s2');
$rJSON->processGotoExpression('jump { value(s1q0) == 4} s0; jump { value(s1q0) == 3} s2');
is($rJSON->lastResponse, 4, '..changed again for multi-statement true expression');
$rJSON->processGotoExpression('jump { score(s1q0) == 100} s0');
is($rJSON->lastResponse, -1, '..and again when score used');
$rJSON->processGotoExpression('jump { score("s1") == 300} s2');
is($rJSON->lastResponse, 4, '..and again when section score total used');
$rJSON->responses({});
$rJSON->questionsAnswered(-1 * $rJSON->questionsAnswered);