Survey branch expressions can now resolve score()s and value()s from
other survey instances.
This commit is contained in:
Patrick Donelan
parent
c1c9521d6e
commit
aa8379188a
2 changed files with 212 additions and 53 deletions
|
|
@ -8,6 +8,10 @@ Package WebGUI::Asset::Wobject::Survey::ExpressionEngine
|
|||
|
||||
This class is used to process Survey gotoExpressions.
|
||||
|
||||
If you want to allow the expression engine to run you need to turn on the enableSurveyExpressionEngine flag
|
||||
in your site config file. This is because no matter how 'Safe' the Safe.pm compartment is, it still has
|
||||
caveats. For example, it doesn't protect you from infinite loops.
|
||||
|
||||
See L<run> for more details.
|
||||
|
||||
=cut
|
||||
|
|
@ -17,6 +21,7 @@ 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 ) } );
|
||||
|
||||
# We need these as semi-globals so that utility subs (which are shared with the safe compartment)
|
||||
|
|
@ -27,20 +32,39 @@ my $scores;
|
|||
my $jump_count;
|
||||
my $validate;
|
||||
my $validTargets;
|
||||
|
||||
my $other_instances;
|
||||
|
||||
=head2 value
|
||||
|
||||
Utility sub that gives expressions access to recorded response values
|
||||
|
||||
value(question_variable) returns the recorded response value for the answer to question_variable
|
||||
|
||||
value(asset_spec, question_variable) returns value(question_variable) on the most recent completed response
|
||||
for the user on the survey instance given by asset_spec (either an assetId or a url)
|
||||
|
||||
=cut
|
||||
|
||||
sub value($) {
|
||||
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("[$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};
|
||||
$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
|
||||
|
|
@ -52,11 +76,26 @@ score(section_variable) returns the summed score for the answers to all the ques
|
|||
|
||||
=cut
|
||||
|
||||
sub score($) {
|
||||
sub score {
|
||||
# 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 $scores = $other_instance->{scores};
|
||||
my $score = $scores->{$key};
|
||||
$session->log->debug("[$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 } );
|
||||
}
|
||||
}
|
||||
my $key = shift;
|
||||
my $score = $scores->{$key};
|
||||
$session->log->debug("[$key] resolves to [$score]");
|
||||
return $score; # scalar variable, so no need to clone
|
||||
return $score; # scalar variable, so no need to clone
|
||||
}
|
||||
|
||||
=head2 jump
|
||||
|
|
@ -71,17 +110,18 @@ catch the first successful jump.
|
|||
sub jump(&$) {
|
||||
my ( $sub, $target ) = @_;
|
||||
$jump_count++;
|
||||
|
||||
|
||||
# If $validTargets known, make sure target is valid
|
||||
if ($validTargets && !exists $validTargets->{$target}) {
|
||||
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
|
||||
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 } );
|
||||
|
|
@ -120,8 +160,12 @@ A gotoExpression is essentially a perl expression that gets evaluated in a Safe
|
|||
|
||||
To access Section/Question recorded response values, the expression calls L<value>.
|
||||
To access Section/Question recorded response scores, the expression calls L<score>.
|
||||
Both L<value> and L<score> allow you to resolve values and scores from other completed survey
|
||||
instances.
|
||||
|
||||
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
|
||||
|
||||
Expressions also have 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:
|
||||
|
|
@ -131,7 +175,7 @@ A very simple expression that checks if the response to s1q1 is 0 might look lik
|
|||
A more complicated gotoExpression with two possible jumps might look like:
|
||||
|
||||
jump { value(q1) > 5 and value(s2q1) =~ m/textmatch/ } target1;
|
||||
jump { avg(value(q1), value(q2), value(q3)) > 10 } target2;
|
||||
jump { avg(value(q1), value(q2), value(home/anotherSurvey, q3)) > 10 } target2;
|
||||
|
||||
=head3 opts (optional)
|
||||
|
||||
|
|
@ -166,52 +210,113 @@ 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} );
|
||||
|
||||
if (!$session->config->get('enableSurveyExpressionEngine')) {
|
||||
( $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();
|
||||
REVAL: {
|
||||
|
||||
# Share our utility subs with the compartment
|
||||
$compartment->share('&value');
|
||||
$compartment->share('&score');
|
||||
$compartment->share('&jump');
|
||||
$compartment->share('&avg');
|
||||
|
||||
# Give them all of List::Util too
|
||||
$compartment->share_from('List::Util', ['&first', '&max', '&maxstr', '&min', '&minstr', '&reduce', '&shuffle', '&sum',]);
|
||||
# Create the Safe compartment
|
||||
my $compartment = Safe->new();
|
||||
|
||||
$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;
|
||||
# Share our utility subs with the compartment
|
||||
$compartment->share('&value');
|
||||
$compartment->share('&score');
|
||||
$compartment->share('&jump');
|
||||
$compartment->share('&avg');
|
||||
|
||||
# Give them all of List::Util too
|
||||
$compartment->share_from( 'List::Util',
|
||||
[ '&first', '&max', '&maxstr', '&min', '&minstr', '&reduce', '&shuffle', '&sum', ] );
|
||||
|
||||
$session->log->debug("Expression is: \"$expression\"");
|
||||
|
||||
$compartment->reval($expression);
|
||||
|
||||
# See if we ran the engine just to check for errors
|
||||
if ( $opts->{validate} ) {
|
||||
if ( $@ && ref $@ ne 'HASH' ) {
|
||||
my $error = $@;
|
||||
$error =~ s/(.*?) at .*/$1/s; # don't reveal too much
|
||||
return $error;
|
||||
}
|
||||
return; # no validation errors
|
||||
}
|
||||
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;
|
||||
}
|
||||
# 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($@);
|
||||
}
|
||||
# See if an unresolved external reference was encountered
|
||||
if ( ref $@ && ref $@ eq 'HASH' && $@->{other_instance} ) {
|
||||
my $asset_spec = $@->{other_instance};
|
||||
$session->log->debug("Resolving external reference: $asset_spec");
|
||||
my $asset;
|
||||
|
||||
# Return undef on failure
|
||||
return;
|
||||
# Instantiate the asset to check it is a Survey instance, and to grab its assetId
|
||||
if ( $session->id->valid($asset_spec) ) {
|
||||
$asset = WebGUI::Asset->new( $session, $asset_spec );
|
||||
}
|
||||
if ( !$asset ) {
|
||||
$asset = WebGUI::Asset->newByUrl( $session, $asset_spec );
|
||||
}
|
||||
if ( ref $asset ne 'WebGUI::Asset::Wobject::Survey' ) {
|
||||
$session->log->warn("Not a survey instance: $asset_spec");
|
||||
return;
|
||||
}
|
||||
if ( !$asset ) {
|
||||
$session->log->warn("Unable to find asset: $asset_spec");
|
||||
return;
|
||||
}
|
||||
my $assetId = $asset->getId;
|
||||
|
||||
# Get the responseId of the most recently completed survey response for the user
|
||||
my $userId = $opts->{userId} || $session->user->userId;
|
||||
my $mostRecentlyCompletedResponseId = $session->db->quickScalar(
|
||||
"select Survey_responseId from Survey_response where userId = ? and assetId = ? and isComplete = 1",
|
||||
[ $userId, $assetId ]
|
||||
);
|
||||
|
||||
if ( !$mostRecentlyCompletedResponseId ) {
|
||||
$session->log->debug("User $userId has not completed Survey");
|
||||
return;
|
||||
}
|
||||
$session->log->debug("Using responseId: $mostRecentlyCompletedResponseId");
|
||||
|
||||
# (re)Instantiate the survey instance using the responseId
|
||||
use WebGUI::Asset::Wobject::Survey;
|
||||
$asset = WebGUI::Asset::Wobject::Survey->newByResponseId( $session, $mostRecentlyCompletedResponseId );
|
||||
$asset->responseIdCookies(0);
|
||||
if ( !$asset ) {
|
||||
$session->log->warn("Unable to instantiate asset by responseId: $mostRecentlyCompletedResponseId");
|
||||
return;
|
||||
}
|
||||
|
||||
$other_instances->{$asset_spec} = {
|
||||
values =>
|
||||
$asset->responseJSON( undef, $mostRecentlyCompletedResponseId )->responseValuesByVariableName,
|
||||
scores =>
|
||||
$asset->responseJSON( undef, $mostRecentlyCompletedResponseId )->responseScoresByVariableName,
|
||||
};
|
||||
$session->log->debug("Successfully looked up asset: $assetId. Repeating reval.");
|
||||
redo REVAL;
|
||||
}
|
||||
|
||||
# Log all other errors (for example compile errors from bad expressions)
|
||||
if ($@) {
|
||||
$session->log->error($@);
|
||||
}
|
||||
|
||||
# Return undef on failure
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -22,23 +22,24 @@ my $session = WebGUI::Test->session;
|
|||
|
||||
#----------------------------------------------------------------------------
|
||||
# Tests
|
||||
my $tests = 36;
|
||||
my $tests = 41;
|
||||
plan tests => $tests + 1;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# put your tests here
|
||||
|
||||
my $usedOk = use_ok('WebGUI::Asset::Wobject::Survey::ExpressionEngine');
|
||||
|
||||
my ($user, $survey);
|
||||
SKIP: {
|
||||
|
||||
skip $tests, "Unable to load ExpressionEngine" unless $usedOk;
|
||||
|
||||
my $e = "WebGUI::Asset::Wobject::Survey::ExpressionEngine";
|
||||
|
||||
WebGUI::Test->originalConfig('enableSurveyExpressionEngine');
|
||||
$session->config->set( 'enableSurveyExpressionEngine', 0 );
|
||||
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!" );
|
||||
|
||||
|
|
@ -109,8 +110,61 @@ SKIP: {
|
|||
undef, 'target is not valid' );
|
||||
is( $e->run( $session, q{jump {1} target}, { values => \%values, validTargets => { target => 1 } } ),
|
||||
'target', '..whereas now it is ok' );
|
||||
|
||||
|
||||
# Create a test user
|
||||
my $user = WebGUI::User->new( $session, 'new' );
|
||||
|
||||
# Create a Survey
|
||||
my $survey = WebGUI::Asset->getImportNode($session)->addChild(
|
||||
{ className => 'WebGUI::Asset::Wobject::Survey',
|
||||
},
|
||||
);
|
||||
isa_ok($survey, 'WebGUI::Asset::Wobject::Survey');
|
||||
my $url = $survey->get('url');
|
||||
my $id = $survey->getId;
|
||||
|
||||
$survey->surveyJSON->newObject([]); # s0
|
||||
$survey->surveyJSON->newObject([0]); # s0q0
|
||||
$survey->surveyJSON->newObject([0,0]); # s0q0a0
|
||||
$survey->surveyJSON->newObject([0]); # s0q1
|
||||
$survey->surveyJSON->newObject([0,1]); # s0q1a0
|
||||
|
||||
$survey->surveyJSON->section([0])->{variable} = 'ext_s0';
|
||||
$survey->surveyJSON->question([0,0])->{variable} = 'ext_s0q0';
|
||||
$survey->surveyJSON->question([0,1])->{variable} = 'ext_s0q1';
|
||||
$survey->surveyJSON->answer([0,0,0])->{recordedAnswer} = 'ext_s0q0a0';
|
||||
$survey->surveyJSON->answer([0,0,0])->{value} = 150; # worth 150 points
|
||||
$survey->surveyJSON->answer([0,1,0])->{recordedAnswer} = 'ext_s0q1a0';
|
||||
$survey->surveyJSON->answer([0,1,0])->{value} = 50; # worth 50 points
|
||||
|
||||
$survey->responseIdCookies(0); # disable cookies so that test code doesn't die
|
||||
my $responseId = $survey->responseId($user->userId);
|
||||
|
||||
my $rJSON = $survey->responseJSON(undef, $responseId);
|
||||
$rJSON->recordResponses({
|
||||
'0-0-0' => 'My ext_s0q0a0 answer',
|
||||
'0-1-0' => 'My ext_s0q1a0 answer',
|
||||
});
|
||||
|
||||
# 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' );
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# Cleanup
|
||||
END { }
|
||||
END {
|
||||
$user->delete if $user;
|
||||
$survey->purge if $survey;
|
||||
}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue