804dbcfd26
One of the file-scoped lexicals in ExpressionEngine wasn't being initialised, which meant that tagged data was being cached across repeated engine runs (including, would you believe, across modperl page requests). The fix includes tests.
568 lines
17 KiB
Perl
568 lines
17 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 List::Util qw/sum/;
|
|
use WebGUI::Asset;
|
|
use WebGUI::Asset::Wobject::Survey;
|
|
Params::Validate::validation_options( on_fail => sub { WebGUI::Error::InvalidParam->throw( error => shift ) } );
|
|
|
|
# We need these as file-scoped lexicals so that our utility subs (which are shared with the safe compartment)
|
|
# can access them.
|
|
# N.B. If you add any new ones, make sure you initialize them in L<run> otherwise they will be cached across
|
|
# unrelated engine runs, which leads to bugs that are hairy to track down
|
|
my $session;
|
|
my $values;
|
|
my $scores;
|
|
my $jumpCount;
|
|
my $validate;
|
|
my $validTargets;
|
|
my $otherInstances;
|
|
my $tags;
|
|
|
|
=head2 value
|
|
|
|
Utility sub that gives expressions access to recorded response values
|
|
|
|
Returns the recorded response value for the answer to question_variable
|
|
|
|
=cut
|
|
|
|
sub value {
|
|
my $key = shift;
|
|
|
|
# Verbatim values are valid variable + _verbatim
|
|
if (my ($verbatimKey) = $key =~ m/(.+)_verbatim/) {
|
|
_validateVariable($verbatimKey, 'value');
|
|
} else {
|
|
_validateVariable($key, 'value');
|
|
}
|
|
my $value = $tags->{$key} || $values->{$key};
|
|
if (ref $value eq 'ARRAY') {
|
|
my $joined = join ', ', @$value;
|
|
if (wantarray) {
|
|
$session->log->debug("value($key) in list context resolves to ($joined)");
|
|
return @$value;
|
|
} else {
|
|
$session->log->debug("value($key) in scalar|void context resolves to \"$joined\"");
|
|
return $joined;
|
|
}
|
|
} else {
|
|
$session->log->debug("value($key) resolves to [$value]");
|
|
return $value;
|
|
}
|
|
}
|
|
|
|
=head2 valueX
|
|
|
|
Same as L<value>, except that first argument is an asset spec (assetId or url), which must resolve
|
|
to a valid survey instance. The sub is applied to the most recent completed response for the user
|
|
on the survey instance given by asset_spec.
|
|
|
|
=cut
|
|
|
|
sub valueX {
|
|
my ( $asset_spec, $key ) = @_;
|
|
|
|
# See if $otherInstances already contains the external survey
|
|
if (my $otherInstance = $otherInstances->{$asset_spec}) {
|
|
my $values = $otherInstance->{values};
|
|
my $value = $values->{$key};
|
|
if (ref $value eq 'ARRAY') {
|
|
my $joined = join ', ', @$value;
|
|
if (wantarray) {
|
|
$session->log->debug("valueX($asset_spec, $key) in list context resolves to ($joined)");
|
|
return @$value;
|
|
} else {
|
|
$session->log->debug("valueX($asset_spec, $key) in scalar|void context resolves to \"$joined\"");
|
|
return $joined;
|
|
}
|
|
} else {
|
|
$session->log->debug("valueX($asset_spec, $key) resolves to [$value]");
|
|
return $value;
|
|
}
|
|
} else {
|
|
# Throw an exception, triggering run() to resolve the external reference and re-run
|
|
die( { otherInstance => $asset_spec } );
|
|
}
|
|
}
|
|
|
|
=head2 score
|
|
|
|
Utility sub that gives expressions access to recorded response scores.
|
|
|
|
If the argument is a question variable, returns the score for the answer selected for question_variable.
|
|
|
|
If the argument is a section variable, returns the summed score for the answers to all the questions in section_variable
|
|
|
|
If two arguments are provided, the first argument is assumed to be an asset spec (assetId or url). In this
|
|
case the sub is applied to the most recent completed response for the user on the survey instance given by asset_spec.
|
|
|
|
=cut
|
|
|
|
sub score {
|
|
my $key = shift;
|
|
_validateVariable($key, 'score');
|
|
my $score = $scores->{$key};
|
|
$session->log->debug("score($key) resolves to [$score]");
|
|
return $score;
|
|
}
|
|
|
|
=head2 scoreX
|
|
|
|
Same as L<score>, except that first argument is an asset spec (assetId or url), which must resolve
|
|
to a valid survey instance. The sub is applied to the most recent completed response for the user
|
|
on the survey instance given by asset_spec.
|
|
|
|
=cut
|
|
|
|
sub scoreX {
|
|
my ( $asset_spec, $key ) = @_;
|
|
|
|
# See if $otherInstances already contains the external survey
|
|
if (my $otherInstance = $otherInstances->{$asset_spec}) {
|
|
my $scores = $otherInstance->{scores};
|
|
my $score = $scores->{$key};
|
|
$session->log->debug("scoreX($asset_spec, $key) resolves to [$score]");
|
|
return $score;
|
|
} else {
|
|
# Throw an exception, triggering run() to resolve the external reference and re-run
|
|
die( { otherInstance => $asset_spec } );
|
|
}
|
|
}
|
|
|
|
=head2 _validateVariable ($key, $fn)
|
|
|
|
Convenience sub to do optional validation of variable names
|
|
|
|
=head3 key
|
|
|
|
Variable name to validate
|
|
|
|
=head3 fn
|
|
|
|
Function name of caller (for diagnostic output)
|
|
|
|
=cut
|
|
|
|
sub _validateVariable {
|
|
my $key = shift;
|
|
my $fn = shift || 'unspecified function';
|
|
if ( $validTargets && !exists $validTargets->{$key} ) {
|
|
my $error = "Param [$key] to $fn is not a valid variable name";
|
|
$session->log->debug($error);
|
|
die($error) if $validate;
|
|
return;
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
=head2 answered
|
|
|
|
Returns true/false depending on whether use has actually reached and responded to the given question
|
|
|
|
If two arguments are provided, the first argument is assumed to be an asset spec (assetId or url). In this
|
|
case the sub is applied to the most recent completed response for the user on the survey instance given by asset_spec.
|
|
|
|
=cut
|
|
|
|
sub answered {
|
|
my $key = shift;
|
|
|
|
_validateVariable($key, 'answered');
|
|
my $answered = exists $values->{$key};
|
|
$session->log->debug("answered($key) returns [$answered]");
|
|
return $answered;
|
|
}
|
|
|
|
=head2 answeredX
|
|
|
|
Same as L<answered>, except that first argument is an asset spec (assetId or url), which must resolve
|
|
to a valid survey instance. The sub is applied to the most recent completed response for the user
|
|
on the survey instance given by asset_spec.
|
|
|
|
=cut
|
|
|
|
sub answeredX {
|
|
my ( $asset_spec, $key ) = @_;
|
|
|
|
# See if $otherInstances already contains the external survey
|
|
if (my $otherInstance = $otherInstances->{$asset_spec}) {
|
|
my $values = $otherInstance->{values};
|
|
my $answered = exists $values->{$key};
|
|
$session->log->debug("answeredX($asset_spec, $key) returns [$answered]");
|
|
return $answered;
|
|
} else {
|
|
# Throw an exception, triggering run() to resolve the external reference and re-run
|
|
die( { otherInstance => $asset_spec } );
|
|
}
|
|
}
|
|
|
|
=head2 tag ($name, [$value])
|
|
|
|
Utility sub that allows expressions to tag data
|
|
|
|
=head3 $name
|
|
|
|
Name of tag to set
|
|
|
|
=head3 $value (optional)
|
|
|
|
Value of tag to set. Defaults to 1 (boolean true flag).
|
|
|
|
=cut
|
|
|
|
sub tag {
|
|
my ($name, $value) = @_;
|
|
$value = 1 if !defined $value;
|
|
$session->log->debug("Setting tag [$name] to [$value]");
|
|
$tags->{$name} = $value;
|
|
}
|
|
|
|
=head2 tagged ($name)
|
|
|
|
Utility sub that gives expressions access to tagged data
|
|
|
|
=head3 $name
|
|
|
|
Name of tag whose value is returned.
|
|
|
|
=cut
|
|
|
|
sub tagged {
|
|
my ($name) = @_;
|
|
if (@_ == 2) {
|
|
my $args = join ',', @_;
|
|
$session->log->warn("Two arguments passed to tagged($args). Did you mean tag($args)?");
|
|
}
|
|
my $value = $tags->{$name};
|
|
$session->log->debug("tagged($name) resolves to [$value]");
|
|
return $value;
|
|
}
|
|
|
|
=head2 taggedX
|
|
|
|
Same as L<tagged>, except that first argument is an asset spec (assetId or url), which must resolve
|
|
to a valid survey instance. The sub is applied to the most recent completed response for the user
|
|
on the survey instance given by asset_spec.
|
|
|
|
=cut
|
|
|
|
sub taggedX {
|
|
my ( $asset_spec, $name ) = @_;
|
|
|
|
if (@_ == 3) {
|
|
my $args = join ',', @_;
|
|
$session->log->warn("Three arguments passed to taggedX($args). Did you mean tag($args)?");
|
|
}
|
|
# See if $otherInstances already contains the external survey
|
|
if (my $otherInstance = $otherInstances->{$asset_spec}) {
|
|
my $tags = $otherInstance->{tags};
|
|
|
|
my $value = $tags->{$name};
|
|
$session->log->debug("taggedX($asset_spec, $name) returns [$value]");
|
|
return $value;
|
|
} else {
|
|
# Throw an exception, triggering run() to resolve the external reference and re-run
|
|
die( { otherInstance => $asset_spec } );
|
|
}
|
|
}
|
|
|
|
=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 ) = @_;
|
|
$jumpCount++;
|
|
|
|
# If $validTargets known, make sure target is valid
|
|
if (!_validateVariable($target, 'jump')) {
|
|
return; # skip jump but continue with expression
|
|
}
|
|
|
|
if ( $sub->() ) {
|
|
$session->log->debug("jump call #$jumpCount is truthy");
|
|
die( { jump => $target } );
|
|
}
|
|
else {
|
|
$session->log->debug("jump call #$jumpCount is falsey");
|
|
}
|
|
}
|
|
|
|
=head2 exitUrl ( [$url] )
|
|
|
|
Same as L<jump> except that instead of a jump, triggers survey exit
|
|
|
|
=head3 url (optional)
|
|
|
|
Url to exit to. If not given, the Survey instance's exitUrl property will be used.
|
|
|
|
=cut
|
|
|
|
sub exitUrl {
|
|
my ( $url ) = @_;
|
|
|
|
$session->log->debug("exitUrl($url)");
|
|
die( { exitUrl => $url } );
|
|
}
|
|
|
|
|
|
=head2 restart ( $sub )
|
|
|
|
Same as L<jump> except that instead of a jump, triggers the Survey to restart
|
|
|
|
=cut
|
|
|
|
sub restart {
|
|
$session->log->debug("restart()");
|
|
die( { restart => 1 } );
|
|
}
|
|
|
|
=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 round
|
|
|
|
Utility sub shared with Safe compartment to allows expressions to easily round numbers
|
|
|
|
=cut
|
|
|
|
sub round {
|
|
my ($number, $precision) = @_;
|
|
$precision ||= 0;
|
|
return sprintf("%.${precision}f", $number);
|
|
}
|
|
|
|
=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>.
|
|
To determine if a user reached and answered a question, the expression calls L<answered>.
|
|
|
|
All of these subs 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 => {} } );
|
|
|
|
# Initialize all file-scoped lexicals that our Safe utility subs have access to
|
|
$session = $s;
|
|
$values = $opts->{values} || {};
|
|
$scores = $opts->{scores} || {};
|
|
$jumpCount = 0;
|
|
$validate = $opts->{validate};
|
|
$validTargets = $opts->{validTargets};
|
|
$tags = $opts->{tags} || {};
|
|
$otherInstances = {};
|
|
|
|
if ( !$session->config->get('enableSurveyExpressionEngine') ) {
|
|
$session->log->debug('enableSurveyExpressionEngine config option disabled, skipping');
|
|
return;
|
|
}
|
|
|
|
REVAL: {
|
|
|
|
# Create the Safe compartment
|
|
my $compartment = Safe->new();
|
|
$compartment->permit(qw(sort));
|
|
|
|
# Share our utility subs with the compartment
|
|
$compartment->share('&value');
|
|
$compartment->share('&valueX');
|
|
$compartment->share('&score');
|
|
$compartment->share('&scoreX');
|
|
$compartment->share('&answered');
|
|
$compartment->share('&answeredX');
|
|
$compartment->share('&tag');
|
|
$compartment->share('&tagged');
|
|
$compartment->share('&taggedX');
|
|
$compartment->share('&jump');
|
|
$compartment->share('&exitUrl');
|
|
$compartment->share('&restart');
|
|
$compartment->share('&avg');
|
|
$compartment->share('&round');
|
|
|
|
# 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') {
|
|
if (my $target = $@->{jump}) {
|
|
return { jump => $target, tags => $tags };
|
|
}
|
|
if (exists $@->{exitUrl}) { # url might be undefined
|
|
return { exitUrl => $@->{exitUrl}, tags => $tags };
|
|
}
|
|
if (my $restart = $@->{restart}) {
|
|
return { restart => $restart, tags => $tags };
|
|
}
|
|
}
|
|
|
|
# See if an unresolved external reference was encountered
|
|
if ( ref $@ && ref $@ eq 'HASH' && $@->{otherInstance} ) {
|
|
my $asset_spec = $@->{otherInstance};
|
|
$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 order by endDate desc limit 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
|
|
$asset = WebGUI::Asset::Wobject::Survey->newByResponseId( $session, $mostRecentlyCompletedResponseId );
|
|
if ( !$asset ) {
|
|
$session->log->warn("Unable to instantiate asset by responseId: $mostRecentlyCompletedResponseId");
|
|
return;
|
|
}
|
|
|
|
my $rJSON = $asset->responseJSON( undef, $mostRecentlyCompletedResponseId );
|
|
$otherInstances->{$asset_spec} = {
|
|
values => $rJSON->responseValues( indexBy => 'variable' ),
|
|
scores => $rJSON->responseScores( indexBy => 'variable' ),
|
|
tags => $rJSON->tags,
|
|
};
|
|
$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; # Return undef on failure
|
|
}
|
|
|
|
# If we reach here, no jump was issued, meaning that we probably just processed an expression that did some tagging
|
|
return { jump => undef, tags => $tags };
|
|
}
|
|
}
|
|
|
|
1;
|