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

Survey branch expressions can now resolve score()s and value()s from

Browse source 
other survey instances.
This commit is contained in:
Patrick Donelan 2009-04-09 04:04:39 +00:00
parent c1c9521d6e
commit aa8379188a
2 changed files with 212 additions and 53 deletions
Download patch file Download diff file Expand all files Collapse all files

191
lib/WebGUI/Asset/Wobject/Survey/ExpressionEngine.pm
View file

@ -8,6 +8,10 @@ Package WebGUI::Asset::Wobject::Survey::ExpressionEngine
This class is used to process Survey gotoExpressions. 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. See L<run> for more details.
=cut =cut
@ -17,6 +21,7 @@ use Params::Validate qw(:all);
use Safe; use Safe;
use Data::Dumper; use Data::Dumper;
use List::Util qw/sum/; use List::Util qw/sum/;
use WebGUI::Asset;
Params::Validate::validation_options( on_fail => sub { WebGUI::Error::InvalidParam->throw( error => shift ) } ); 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) # We need these as semi-globals so that utility subs (which are shared with the safe compartment)
@ -27,6 +32,7 @@ my $scores;
my $jump_count; my $jump_count;
my $validate; my $validate;
my $validTargets; my $validTargets;
my $other_instances;
=head2 value =head2 value
@ -34,13 +40,31 @@ 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(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 =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 $key = shift;
my $value = $values->{$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 =head2 score
@ -52,11 +76,26 @@ score(section_variable) returns the summed score for the answers to all the ques
=cut =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 $key = shift;
my $score = $scores->{$key}; my $score = $scores->{$key};
$session->log->debug("[$key] resolves to [$score]"); $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 =head2 jump
@ -73,12 +112,13 @@ sub jump(&$) {
$jump_count++; $jump_count++;
# If $validTargets known, make sure target is valid # If $validTargets known, make sure target is valid
if ($validTargets && !exists $validTargets->{$target}) { if ( $validTargets && !exists $validTargets->{$target} ) {
$session->log->debug("Invalid target [$target]"); $session->log->debug("Invalid target [$target]");
if ($validate) { if ($validate) {
die("Invalid jump target \"$target\""); # bail and report error die("Invalid jump target \"$target\""); # bail and report error
} else { }
return; # skip jump but continue with expression else {
return; # skip jump but continue with expression
} }
} }
@ -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 values, the expression calls L<value>.
To access Section/Question recorded response scores, the expression calls L<score>. 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. 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..). 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:
@ -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: A more complicated gotoExpression with two possible jumps might look like:
jump { value(q1) > 5 and value(s2q1) =~ m/textmatch/ } target1; 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) =head3 opts (optional)
@ -166,52 +210,113 @@ 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, $values, $scores, $jump_count, $validate, $validTargets ) = ( $s, $opts->{values}, $opts->{scores}, 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')) { if ( !$session->config->get('enableSurveyExpressionEngine') ) {
$session->log->debug('enableSurveyExpressionEngine config option disabled, skipping'); $session->log->debug('enableSurveyExpressionEngine config option disabled, skipping');
return; return;
} }
# Create the Safe compartment REVAL: {
my $compartment = Safe->new();
# Share our utility subs with the compartment # Create the Safe compartment
$compartment->share('&value'); my $compartment = Safe->new();
$compartment->share('&score');
$compartment->share('&jump');
$compartment->share('&avg');
# Give them all of List::Util too # Share our utility subs with the compartment
$compartment->share_from('List::Util', ['&first', '&max', '&maxstr', '&min', '&minstr', '&reduce', '&shuffle', '&sum',]); $compartment->share('&value');
$compartment->share('&score');
$compartment->share('&jump');
$compartment->share('&avg');
$session->log->debug("Expression is: \"$expression\""); # Give them all of List::Util too
$compartment->reval($expression); $compartment->share_from( 'List::Util',
[ '&first', '&max', '&maxstr', '&min', '&minstr', '&reduce', '&shuffle', '&sum', ] );
# See if we ran the engine just to check for errors $session->log->debug("Expression is: \"$expression\"");
if ($opts->{validate}) {
if ($@ && ref $@ ne 'HASH') { $compartment->reval($expression);
my $error = $@;
$error =~ s/(.*?) at .*/$1/s; # don't reveal too much # See if we ran the engine just to check for errors
return $error; 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 # A successful jump triggers a hashref containing the jump target to be thrown
if ( ref $@ && ref $@ eq 'HASH' && $@->{jump} ) { if ( ref $@ && ref $@ eq 'HASH' && $@->{jump} ) {
my $jump = $@->{jump}; my $jump = $@->{jump};
$session->log->debug("Returning [$jump]"); $session->log->debug("Returning [$jump]");
return $jump; return $jump;
} }
# Log all other errors (for example compile errors from bad expressions) # See if an unresolved external reference was encountered
if ($@) { if ( ref $@ && ref $@ eq 'HASH' && $@->{other_instance} ) {
$session->log->error($@); my $asset_spec = $@->{other_instance};
} $session->log->debug("Resolving external reference: $asset_spec");
my $asset;
# Return undef on failure # Instantiate the asset to check it is a Survey instance, and to grab its assetId
return; 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; 1;

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

@ -22,23 +22,24 @@ my $session = WebGUI::Test->session;
#---------------------------------------------------------------------------- #----------------------------------------------------------------------------
# Tests # Tests
my $tests = 36; my $tests = 41;
plan tests => $tests + 1; plan tests => $tests + 1;
#---------------------------------------------------------------------------- #----------------------------------------------------------------------------
# put your tests here # put your tests here
my $usedOk = use_ok('WebGUI::Asset::Wobject::Survey::ExpressionEngine'); my $usedOk = use_ok('WebGUI::Asset::Wobject::Survey::ExpressionEngine');
my ($user, $survey);
SKIP: { SKIP: {
skip $tests, "Unable to load ExpressionEngine" unless $usedOk; skip $tests, "Unable to load ExpressionEngine" unless $usedOk;
my $e = "WebGUI::Asset::Wobject::Survey::ExpressionEngine"; my $e = "WebGUI::Asset::Wobject::Survey::ExpressionEngine";
WebGUI::Test->originalConfig('enableSurveyExpressionEngine');
$session->config->set( 'enableSurveyExpressionEngine', 0 );
is( $e->run( $session, 'jump { 1 } target' ), is( $e->run( $session, 'jump { 1 } target' ),
undef, "Nothing happens unless we turn on enableSurveyExpressionEngine in config" ); undef, "Nothing happens unless we turn on enableSurveyExpressionEngine in config" );
WebGUI::Test->originalConfig('enableSurveyExpressionEngine');
$session->config->set( 'enableSurveyExpressionEngine', 1 ); $session->config->set( 'enableSurveyExpressionEngine', 1 );
is( $e->run( $session, 'jump { 1 } target' ), 'target', "..now we're in business!" ); is( $e->run( $session, 'jump { 1 } target' ), 'target', "..now we're in business!" );
@ -109,8 +110,61 @@ SKIP: {
undef, 'target is not valid' ); undef, 'target is not valid' );
is( $e->run( $session, q{jump {1} target}, { values => \%values, 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' );
# 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 # Cleanup
END { } END {
$user->delete if $user;
$survey->purge if $survey;
}