Replaced Survey parseGotoExpression with dedicated ExpressionEngine.
Improved gotoExpression validation error reporting Added lots more tests
This commit is contained in:
Patrick Donelan
parent
83e7163f31
commit
9ea4f1cd20
5 changed files with 325 additions and 202 deletions
183
lib/WebGUI/Asset/Wobject/Survey/ExpressionEngine.pm
Normal file
183
lib/WebGUI/Asset/Wobject/Survey/ExpressionEngine.pm
Normal file
|
|
@ -0,0 +1,183 @@
|
|||
package WebGUI::Asset::Wobject::Survey::ExpressionEngine;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Asset::Wobject::Survey::ExpressionEngine
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class is used to process Survey gotoExpressions.
|
||||
|
||||
See L<run> for more details.
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use Params::Validate qw(:all);
|
||||
use Safe;
|
||||
use Data::Dumper;
|
||||
use List::Util qw/sum/;
|
||||
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 $vars;
|
||||
my $jump_count;
|
||||
my $validate;
|
||||
my $validTargets;
|
||||
|
||||
=head2 var
|
||||
|
||||
Utility sub shared with Safe compartment so that expressions can access allowed vars.
|
||||
|
||||
=cut
|
||||
|
||||
sub var($) {
|
||||
my $key = shift;
|
||||
my $value = $vars->{$key};
|
||||
$session->log->debug("[$key] resolves to [$value]");
|
||||
return $value; # 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 number of values
|
||||
|
||||
=cut
|
||||
|
||||
sub avg {
|
||||
my @vals = @_;
|
||||
return sum(@vals) / @vals;
|
||||
}
|
||||
|
||||
=head2 run ( $session, $expression, $opts )
|
||||
|
||||
Class method.
|
||||
|
||||
Evaluates the given expression in a Safe compartment, giving the expression access to vars.
|
||||
|
||||
=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 response values, the expression calls L<var>.
|
||||
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
|
||||
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 { var(s1q1) == 0 } target
|
||||
|
||||
A more complicated gotoExpression with two possible jumps might look like:
|
||||
|
||||
jump { var('my_var') > 5 and var('my_var2') =~ m/textmatch/ } target1;
|
||||
jump { $avg = (var(q1) + var(q2) + var(q3)) / 3; return $avg > 10 } target2;
|
||||
|
||||
=head3 opts (optional)
|
||||
|
||||
Supported options are:
|
||||
|
||||
=over 3
|
||||
|
||||
=item * vars
|
||||
|
||||
Hashref of vars to make available to the expression via the L<var> utility sub
|
||||
|
||||
=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, $vars, $jump_count, $validate, $validTargets ) = ( $s, $opts->{vars}, 0, $opts->{validate}, $opts->{validTargets} );
|
||||
|
||||
# Create the Safe compartment
|
||||
my $compartment = Safe->new();
|
||||
|
||||
# Share our utility subs with the compartment
|
||||
$compartment->share('&var');
|
||||
$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;
|
||||
}
|
||||
|
||||
# Log all other errors (for example compile errors from bad expressions)
|
||||
if ($@) {
|
||||
$session->log->error($@);
|
||||
}
|
||||
|
||||
# Return undef on failure
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -649,64 +649,21 @@ indicates that we should branch.
|
|||
|
||||
=head3 $gotoExpression
|
||||
|
||||
The gotoExpression.
|
||||
|
||||
A gotoExpression is a string representing a list of expressions (one per line) of the form:
|
||||
|
||||
target: expression
|
||||
target: expression
|
||||
...
|
||||
|
||||
This subroutine iterates through the list, processing each line and, all things being
|
||||
well, evaluates the expression. The first expression to evaluate to true triggers a
|
||||
call to L<"processGoto">.
|
||||
|
||||
The expression should be valid perl. Any section/question variables that you refer to
|
||||
should be written as $var, as if your perl code had access to that variable. In reality,
|
||||
those variables don't exist - they're substituted in via L<parseGotoExpression> and
|
||||
then the expression is evaluated in a safe compartment.
|
||||
|
||||
Here is an example using section variables S1 and S2 as jump targets and question
|
||||
variables Q1-3 in the expression. It jumps to S1 if the user's answer to Q1 has a value
|
||||
of 3, jumps to S2 if Q2 + Q3 < 10, and otherwise doesn't branch at all (the default).
|
||||
|
||||
S1: $Q1 == 3
|
||||
S2: $Q2 + $Q3 < 10
|
||||
|
||||
You can do advanced branching by creating your own variables within the expression, for
|
||||
example, to branch when the average of 3 questions is greater than 5:
|
||||
S1: $avg = ($Q1 + $Q2 + $Q3) / 3; $avg > 5
|
||||
The gotoExpression. See L<WebGUI::Asset::Wobject::Survey::ExpressionEngine> for more info.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub processGotoExpression {
|
||||
my $self = shift;
|
||||
my ($expression) = validate_pos(@_, {type => SCALAR});
|
||||
|
||||
my $responsesByVariableName = $self->responsesByVariableName();
|
||||
|
||||
# Parse gotoExpressions one after the other (first one that's true wins)
|
||||
foreach my $line (split /\n/, $expression) {
|
||||
my $processed = WebGUI::Asset::Wobject::Survey::ResponseJSON->parseGotoExpression($self->session, $line, $responsesByVariableName);
|
||||
|
||||
next if !$processed;
|
||||
|
||||
# Eval expression in a safe compartment
|
||||
# N.B. Expression does not need access to any variables
|
||||
my $compartment = Safe->new();
|
||||
my $result = $compartment->reval($processed->{expression});
|
||||
|
||||
$self->session->log->warn($@) if $@; ## no critic
|
||||
|
||||
if ($result) {
|
||||
$self->session->log->debug("Truthy, goto [$processed->{target}]");
|
||||
$self->processGoto($processed->{target});
|
||||
return $processed;
|
||||
} else {
|
||||
$self->session->log->debug('Falsy, not branching');
|
||||
next;
|
||||
}
|
||||
|
||||
use WebGUI::Asset::Wobject::Survey::ExpressionEngine;
|
||||
my $engine = "WebGUI::Asset::Wobject::Survey::ExpressionEngine";
|
||||
if (my $jump = $engine->run($self->session, $expression, { vars => $self->responsesByVariableName} )) {
|
||||
$self->session->log->debug("Hit. Jumping to [$jump]");
|
||||
$self->processGoto($jump);
|
||||
}
|
||||
$self->session->log->debug("No hits, falling through");
|
||||
return;
|
||||
}
|
||||
|
||||
|
|
@ -788,66 +745,6 @@ sub responsesByVariableName {
|
|||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 parseGotoExpression( ( $expression, $responses)
|
||||
|
||||
Parses a single gotoExpression. Returns undef if processing fails, or the following hashref
|
||||
if things work out well:
|
||||
{ target => $target, expression => $expression }
|
||||
|
||||
=head3 $expression
|
||||
|
||||
The expression to process
|
||||
|
||||
=head3 $responses
|
||||
|
||||
Hashref that maps questionNames to response values
|
||||
|
||||
=head3 Explanation:
|
||||
|
||||
Uses the following simple strategy:
|
||||
|
||||
First, parse the expression as:
|
||||
target: expression
|
||||
|
||||
Replace each "$questionName" with its response value (from the $responses hashref)
|
||||
|
||||
=cut
|
||||
|
||||
sub parseGotoExpression {
|
||||
my $class = shift;
|
||||
my ($session, $expression, $responses) = validate_pos(@_, { isa => 'WebGUI::Session'}, { type => SCALAR }, { type => HASHREF, default => {} });
|
||||
|
||||
$session->log->debug("Parsing gotoExpression: $expression");
|
||||
|
||||
my ( $target, $rest ) = $expression =~ /\s* ([^:]+?) \s* : \s* (.*)/x;
|
||||
|
||||
$session->log->debug("Parsed as Target: [$target], Expression: [$rest]");
|
||||
|
||||
if ( !defined $target ) {
|
||||
$session->log->warn('Target undefined');
|
||||
return;
|
||||
}
|
||||
|
||||
if ( !defined $rest || $rest eq q{} ) {
|
||||
$session->log->warn('Expression undefined');
|
||||
return;
|
||||
}
|
||||
|
||||
# Replace each "$questionName" with its response value
|
||||
while ( my ( $questionName, $response ) = each %{$responses} ) {
|
||||
$rest =~ s/\$$questionName/$response/g;
|
||||
}
|
||||
|
||||
$session->log->debug("Processed as: $rest");
|
||||
|
||||
return {
|
||||
target => $target,
|
||||
expression => $rest,
|
||||
};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getTemplatedText ($text, $responses)
|
||||
|
||||
Scans a string of text for instances of "[[var]]". Looks up each match in the given hash reference
|
||||
|
|
|
|||
|
|
@ -1222,13 +1222,13 @@ sub validateSurvey{
|
|||
my $sNum = $s + 1;
|
||||
my $section = $self->section([$s]);
|
||||
if(! $self->validateGoto($section,$goodTargets)){
|
||||
push @messages,"Section $sNum has invalid Jump target: $section->{goto}";
|
||||
push @messages,"Section $sNum has invalid Jump target: \"$section->{goto}\"";
|
||||
}
|
||||
if(! $self->validateGotoInfiniteLoop($section)){
|
||||
push(@messages,"Section $sNum jumps to itself.");
|
||||
push @messages,"Section $sNum jumps to itself.";
|
||||
}
|
||||
if(! $self->validateGotoExpression($section,$goodTargets)){
|
||||
push(@messages,"Section $sNum has invalid Jump Expression: $section->{gotoExpression}");
|
||||
if(my $error = $self->validateGotoExpression($section,$goodTargets)){
|
||||
push @messages,"Section $sNum has invalid Jump Expression: \"$section->{gotoExpression}\". Error: $error";
|
||||
}
|
||||
if (my $var = $section->{variable}) {
|
||||
if (my $count = $duplicateTargets->{$var}) {
|
||||
|
|
@ -1242,19 +1242,19 @@ sub validateSurvey{
|
|||
my $qNum = $q + 1;
|
||||
my $question = $self->question([$s,$q]);
|
||||
if(! $self->validateGoto($question,$goodTargets)){
|
||||
push(@messages,"Section $sNum Question $qNum has invalid Jump target: $question->{goto}");
|
||||
push @messages,"Section $sNum Question $qNum has invalid Jump target: \"$question->{goto}\"";
|
||||
}
|
||||
if(! $self->validateGotoInfiniteLoop($question)){
|
||||
push(@messages,"Section $sNum Question $qNum jumps to itself.");
|
||||
push @messages,"Section $sNum Question $qNum jumps to itself.";
|
||||
}
|
||||
if(! $self->validateGotoExpression($question,$goodTargets)){
|
||||
push(@messages,"Section $sNum Question $qNum has invalid Jump Expression: $question->{gotoExpression}");
|
||||
if(my $error = $self->validateGotoExpression($question,$goodTargets)){
|
||||
push @messages,"Section $sNum Question $qNum has invalid Jump Expression: \"$question->{gotoExpression}\". Error: $error";
|
||||
}
|
||||
if($#{$question->{answers}} < 0){
|
||||
push(@messages,"Section $sNum Question $qNum does not have any answers.");
|
||||
push @messages,"Section $sNum Question $qNum does not have any answers.";
|
||||
}
|
||||
if(! $question->{text} =~ /\w/){
|
||||
push(@messages,"Section $sNum Question $qNum does not have any text.");
|
||||
push @messages,"Section $sNum Question $qNum does not have any text.";
|
||||
}
|
||||
if (my $var = $question->{variable}) {
|
||||
if (my $count = $duplicateTargets->{$var}) {
|
||||
|
|
@ -1268,13 +1268,13 @@ sub validateSurvey{
|
|||
my $aNum = $a + 1;
|
||||
my $answer = $self->answer([$s,$q,$a]);
|
||||
if(! $self->validateGoto($answer,$goodTargets)){
|
||||
push(@messages,"Section $sNum Question $qNum Answer $aNum has invalid Jump target: $answer->{goto}");
|
||||
push @messages,"Section $sNum Question $qNum Answer $aNum has invalid Jump target: \"$answer->{goto}\"";
|
||||
}
|
||||
if(! $self->validateGotoInfiniteLoop($answer)){
|
||||
push(@messages,"Section $sNum Question $qNum Answer $aNum jumps to itself.");
|
||||
push @messages,"Section $sNum Question $qNum Answer $aNum jumps to itself.";
|
||||
}
|
||||
if(! $self->validateGotoExpression($answer,$goodTargets)){
|
||||
push(@messages,"Section $sNum Question $qNum Answer $aNum has invalid Jump Expression: $answer->{gotoExpression}");
|
||||
if(my $error = $self->validateGotoExpression($answer,$goodTargets)){
|
||||
push @messages,"Section $sNum Question $qNum Answer $aNum has invalid Jump Expression: \"$answer->{gotoExpression}\". Error: $error";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
@ -1301,10 +1301,12 @@ sub validateGotoInfiniteLoop{
|
|||
sub validateGotoExpression{
|
||||
my $self = shift;
|
||||
my $object = shift;
|
||||
return 1 unless $object->{gotoExpression} =~ /\w/;
|
||||
my $goodTargets = shift;
|
||||
return unless $object->{gotoExpression};
|
||||
|
||||
# The best we can do is return true/false on whether the gotoExpression parses
|
||||
return WebGUI::Asset::Wobject::Survey::ResponseJSON->parseGotoExpression($self->session, $object->{gotoExpression});
|
||||
use WebGUI::Asset::Wobject::Survey::ExpressionEngine;
|
||||
my $engine = "WebGUI::Asset::Wobject::Survey::ExpressionEngine";
|
||||
return $engine->run($self->session, $object->{gotoExpression}, { validate => 1, validTargets => $goodTargets } );
|
||||
}
|
||||
|
||||
=head2 section ($address)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue