merge to 10219

lib/WebGUI/Asset/Wobject/Survey/ExpressionEngine.pm

@@ -0,0 +1,217 @@
+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 $values;
+my $scores;
+my $jump_count;
+my $validate;
+my $validTargets;
+ 
+=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
+
+=cut
+
+sub value($) {
+    my $key   = shift;
+    my $value = $values->{$key};
+    $session->log->debug("[$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($) {
+    my $key   = shift;
+    my $score = $scores->{$key};
+    $session->log->debug("[$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>.
+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 { 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(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;
+    }
+
+    # 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;
+    }
+
+    # Log all other errors (for example compile errors from bad expressions)
+    if ($@) {
+        $session->log->error($@);
+    }
+
+    # Return undef on failure
+    return;
+}
+
+1;