322 lines
10 KiB
Perl
322 lines
10 KiB
Perl
package WebGUI::Asset::Wobject::Survey::ExpressionEngine;
|
|
|
|
=head1 NAME
|
|
|
|
Package WebGUI::Asset::Wobject::Survey::ExpressionEngine
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
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
|
|
|
|
use strict;
|
|
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)
|
|
# can access them.
|
|
my $session;
|
|
my $values;
|
|
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 {
|
|
# 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("value($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("value($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 {
|
|
# 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("score($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("score($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.
|
|
|
|
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 list
|
|
|
|
=cut
|
|
|
|
sub avg {
|
|
my @vals = @_;
|
|
return sum(@vals) / @vals;
|
|
}
|
|
|
|
=head2 run ( $session, $expression, $opts )
|
|
|
|
Class method.
|
|
|
|
Evaluates the given expression in a Safe compartment.
|
|
|
|
=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 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.
|
|
|
|
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:
|
|
|
|
jump { value(s1q1) == 0 } target
|
|
|
|
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(home/anotherSurvey, q3)) > 10 } target2;
|
|
|
|
=head3 opts (optional)
|
|
|
|
Supported options are:
|
|
|
|
=over 3
|
|
|
|
=item * values
|
|
|
|
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
|
|
|
|
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, $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;
|
|
}
|
|
|
|
REVAL: {
|
|
|
|
# Create the Safe compartment
|
|
my $compartment = Safe->new();
|
|
|
|
# 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
|
|
}
|
|
|
|
# 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;
|
|
}
|
|
|
|
# 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;
|
|
|
|
# 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;
|