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;
|