oqapi/webgui
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Made Survey ExpressionEngine disabled by default, controlled via config

Browse source 
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
Download patch file Download diff file Expand all files Collapse all files

8
docs/upgrades/upgrade_7.7.2-7.7.3.pl
View file

@ -33,6 +33,7 @@ my $session = start(); # this line required
# upgrade functions go here # upgrade functions go here
addSurveyQuizModeColumns($session); addSurveyQuizModeColumns($session);
addSurveyExpressionEngineConfigFlag($session);
finish($session); # this line required finish($session); # this line required
@ -54,6 +55,13 @@ sub addSurveyQuizModeColumns{
print "Done.\n" unless $quiet; 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 -------------------------------- # -------------- DO NOT EDIT BELOW THIS LINE --------------------------------
#---------------------------------------------------------------------------- #----------------------------------------------------------------------------

66
lib/WebGUI/Asset/Wobject/Survey/ExpressionEngine.pm
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) # We need these as semi-globals so that utility subs (which are shared with the safe compartment)
# can access them. # can access them.
my $session; my $session;
my $vars; my $values;
my $scores;
my $jump_count; my $jump_count;
my $validate; my $validate;
my $validTargets; 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 =cut
sub var($) { sub value($) {
my $key = shift; my $key = shift;
my $value = $vars->{$key}; my $value = $values->{$key};
$session->log->debug("[$key] resolves to [$value]"); $session->log->debug("[$key] resolves to [$value]");
return $value; # scalar variable, so no need to clone 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 =head2 jump
Utility sub shared with Safe compartment so that expressions can call individual jump tests. Utility sub shared with Safe compartment so that expressions can call individual jump tests.
@ -74,8 +93,7 @@ sub jump(&$) {
=head2 avg =head2 avg
Utility sub shared with Safe compartment to allows expressions to easily compute the average Utility sub shared with Safe compartment to allows expressions to easily compute the average of a list
of a number of values
=cut =cut
@ -88,7 +106,7 @@ sub avg {
Class method. 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 =head3 session
@ -100,19 +118,20 @@ The expression to run.
A gotoExpression is essentially a perl expression that gets evaluated in a Safe compartment. 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. 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 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..). 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: 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: A more complicated gotoExpression with two possible jumps might look like:
jump { var('my_var') > 5 and var('my_var2') =~ m/textmatch/ } target1; jump { value(q1) > 5 and value(s2q1) =~ m/textmatch/ } target1;
jump { $avg = (var(q1) + var(q2) + var(q3)) / 3; return $avg > 10 } target2; jump { avg(value(q1), value(q2), value(q3)) > 10 } target2;
=head3 opts (optional) =head3 opts (optional)
@ -120,9 +139,18 @@ Supported options are:
=over 3 =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 =item * validate
@ -138,13 +166,19 @@ sub run {
= validate_pos( @_, { isa => 'WebGUI::Session' }, { type => SCALAR }, { type => HASHREF, default => {} } ); = validate_pos( @_, { isa => 'WebGUI::Session' }, { type => SCALAR }, { type => HASHREF, default => {} } );
# Init package globals # 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 # Create the Safe compartment
my $compartment = Safe->new(); my $compartment = Safe->new();
# Share our utility subs with the compartment # Share our utility subs with the compartment
$compartment->share('&var'); $compartment->share('&value');
$compartment->share('&score');
$compartment->share('&jump'); $compartment->share('&jump');
$compartment->share('&avg'); $compartment->share('&avg');

74
lib/WebGUI/Asset/Wobject/Survey/ResponseJSON.pm
View file

@ -657,9 +657,14 @@ sub processGotoExpression {
my $self = shift; my $self = shift;
my ($expression) = validate_pos(@_, {type => SCALAR}); 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; use WebGUI::Asset::Wobject::Survey::ExpressionEngine;
my $engine = "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->session->log->debug("Hit. Jumping to [$jump]");
$self->processGoto($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. Returns a lookup table to question variable names and recorded response values.
@ -718,7 +723,7 @@ the L<responses> hash.
=cut =cut
sub responsesByVariableName { sub responseValuesByVariableName {
my $self = shift; my $self = shift;
my %lookup; 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) =head2 getTemplatedText ($text, $responses)
Scans a string of text for instances of "[[var]]". Looks up each match in the given hash reference 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}; 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 # 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 # 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.. # Collect all the questions to be shown on the next page..
my @questions; my @questions;
@ -844,7 +902,7 @@ sub nextQuestions {
my %questionCopy = %{$self->survey->question( $address )}; my %questionCopy = %{$self->survey->question( $address )};
# Do text replacement # Do text replacement
$questionCopy{text} = $self->getTemplatedText($questionCopy{text}, $responsesByVariableName); $questionCopy{text} = $self->getTemplatedText($questionCopy{text}, $responseValuesByVariableName);
# Add any extra fields we want.. # Add any extra fields we want..
$questionCopy{id} = $self->questionId($sIndex, $qIndex); $questionCopy{id} = $self->questionId($sIndex, $qIndex);
@ -856,7 +914,7 @@ sub nextQuestions {
my %answerCopy = %{ $self->survey->answer( [ $sIndex, $qIndex, $aIndex ] ) }; my %answerCopy = %{ $self->survey->answer( [ $sIndex, $qIndex, $aIndex ] ) };
# Do text replacement # Do text replacement
$answerCopy{text} = $self->getTemplatedText($answerCopy{text}, $responsesByVariableName); $answerCopy{text} = $self->getTemplatedText($answerCopy{text}, $responseValuesByVariableName);
# Add any extra fields we want.. # Add any extra fields we want..
$answerCopy{id} = $self->answerId($sIndex, $qIndex, $aIndex); $answerCopy{id} = $self->answerId($sIndex, $qIndex, $aIndex);
@ -1107,7 +1165,7 @@ recorded value, and the id of the answer.
=cut =cut
# TODO: This sub should make use of responsesByVariableName # TODO: This sub should make use of responseValuesByVariableName
sub returnResponseForReporting { sub returnResponseForReporting {
my $self = shift; my $self = shift;

80
t/Asset/Wobject/Survey/ExpressionEngine.t
View file

@ -22,7 +22,7 @@ my $session = WebGUI::Test->session;
#---------------------------------------------------------------------------- #----------------------------------------------------------------------------
# Tests # Tests
my $tests = 33; my $tests = 36;
plan tests => $tests + 1; plan tests => $tests + 1;
#---------------------------------------------------------------------------- #----------------------------------------------------------------------------
@ -36,64 +36,78 @@ SKIP: {
my $e = "WebGUI::Asset::Wobject::Survey::ExpressionEngine"; 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, n => 5,
s1 => 'my string', s1 => 'my string',
); );
my %scores = (
n1 => 1,
n2 => 2,
);
# These should all jump to 'target' # These should all jump to 'target'
my @should_pass = ( my @should_pass = (
q{jump { 1 } target}, q{jump { 1 } target},
q{jump { return 1 } target}, q{jump { return 1 } target},
q{jump { "string" } target}, q{jump { "string" } target},
q{jump { var(n) == 5 } target}, q{jump { value(n) == 5 } target},
q{jump { var(n) > 0 } target}, q{jump { value(n) > 0 } target},
q{jump { var(s1) eq "my string" } target}, q{jump { value(s1) eq "my string" } target},
q{jump { var(s1) =~ m/my/ } target}, q{jump { value(s1) =~ m/my/ } target},
q{jump { var(n) == 4 or var(n) == 5 } target}, q{jump { value(n) == 4 or value(n) == 5 } target},
q{jump { var(n) == 5 && var(n) > 0 } target}, q{jump { value(n) == 5 && value(n) > 0 } target},
q{jump { (var(n) > 1 ? 10 : 11) == 10 } 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; $a++; $a++; $a *= 2; $a == 6 } target},
q{jump { @a = (1..10); $a[0] == 1 && @a == 10 } target}, # arrays 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 { if (value(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 = (value(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 { $q2 = 3; avg(value(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 { value(n) == 5 } target; jump { value(n) == 5 } targetX}, # first jump wins
q{jump { var(n) == 0 } targetX; jump { var(n) == 5 } target}, # false jumps ignored 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 { 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 { 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 = ( my @should_fail = (
q{}, # empty q{}, # empty
q{ return }, # empty q{ return }, # empty
q{1}, # doesn't call jump q{1}, # doesn't call jump
q|{|, # doesn't compile q|{|, # doesn't compile
q{blah-dee-blah-blah}, # rubbish expression q{blah-dee-blah-blah}, # rubbish expression
q{jump {} target}, # empty anon sub to jump q{jump {} target}, # empty anon sub to jump
q{jump { 0 } target}, # false sub to jump q{jump { 0 } target}, # false sub to jump
q{jump { var(n) == 500 } target}, q{jump { value(n) == 500 } target},
q{jump { var(s1) eq 'blah' } target}, q{jump { value(s1) eq 'blah' } target},
q{jump { time } target}, # time and other opcodes not allowed q{jump { time } target}, # time and other opcodes not allowed
); );
for my $expr (@should_pass) { 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) { 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 } ); $e->run( $session, q{jump {$x = value(s1); $x = 'X'} target}, { values => \%values } );
is( $vars{s1}, 'my string', "Expression can't modify vars" ); is( $values{s1}, 'my string', "Expression can't modify values" );
like( $e->run( $session, '{', { validate => 1 } ), qr/Missing right curly/, "Validation option works" ); like( $e->run( $session, '{', { validate => 1 } ), qr/Missing right curly/, "Validation option works" );
# Check validTargets option # 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' ); 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' ); 'target', '..whereas now it is ok' );
} }

46
t/Asset/Wobject/Survey/ResponseJSON.t
View file

@ -22,7 +22,7 @@ my $session = WebGUI::Test->session;
#---------------------------------------------------------------------------- #----------------------------------------------------------------------------
# Tests # Tests
my $tests = 59; my $tests = 64;
plan tests => $tests + 1; 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([0])->{variable} = 's0'; # our first test jump target
$rJSON->survey->section([2])->{variable} = 's2'; # our second 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 $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 {'); $rJSON->processGotoExpression('blah-dee-blah-blah {');
is($rJSON->lastResponse, 4, '..unchanged after duff expression'); 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'); 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'); 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'); 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'); 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->responses({});
$rJSON->questionsAnswered(-1 * $rJSON->questionsAnswered); $rJSON->questionsAnswered(-1 * $rJSON->questionsAnswered);