Ready for 7.10.29 development.
This commit is contained in:
Colin Kuskie
commit
c806f99b7b
4236 changed files with 1217679 additions and 0 deletions
568
lib/WebGUI/Asset/Wobject/Survey/ExpressionEngine.pm
Normal file
568
lib/WebGUI/Asset/Wobject/Survey/ExpressionEngine.pm
Normal file
|
|
@ -0,0 +1,568 @@
|
|||
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;
|
||||
1619
lib/WebGUI/Asset/Wobject/Survey/ResponseJSON.pm
Normal file
1619
lib/WebGUI/Asset/Wobject/Survey/ResponseJSON.pm
Normal file
File diff suppressed because it is too large
Load diff
1713
lib/WebGUI/Asset/Wobject/Survey/SurveyJSON.pm
Normal file
1713
lib/WebGUI/Asset/Wobject/Survey/SurveyJSON.pm
Normal file
File diff suppressed because it is too large
Load diff
798
lib/WebGUI/Asset/Wobject/Survey/Test.pm
Normal file
798
lib/WebGUI/Asset/Wobject/Survey/Test.pm
Normal file
|
|
@ -0,0 +1,798 @@
|
|||
package WebGUI::Asset::Wobject::Survey::Test;
|
||||
|
||||
use strict;
|
||||
use base qw/WebGUI::Crud/;
|
||||
use WebGUI::International;
|
||||
use Test::Deep::NoTest;
|
||||
use JSON::PP;
|
||||
use Data::Dumper;
|
||||
use Params::Validate qw(:all);
|
||||
Params::Validate::validation_options( on_fail => sub { WebGUI::Error::InvalidParam->throw( error => shift ) } );
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Asset::Wobject::Survey::Test;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Base class for Survey tests
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These methods are available from this class:
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 crud_definition ( )
|
||||
|
||||
WebGUI::Crud definition for this class.
|
||||
|
||||
=head3 tableName
|
||||
|
||||
Survey_test
|
||||
|
||||
=head3 tableKey
|
||||
|
||||
testId
|
||||
|
||||
=head3 sequenceKey
|
||||
|
||||
assetId, e.g. each Survey instance has its own sequence of tests.
|
||||
|
||||
=head3 properties
|
||||
|
||||
=head4 assetId
|
||||
|
||||
Identifies the Survey instance.
|
||||
|
||||
=head4 name
|
||||
|
||||
A name for the test
|
||||
|
||||
=head4 test
|
||||
|
||||
The test spec
|
||||
|
||||
=cut
|
||||
|
||||
sub crud_definition {
|
||||
my ( $class, $session ) = @_;
|
||||
my $definition = $class->SUPER::crud_definition($session);
|
||||
$definition->{tableName} = 'Survey_test';
|
||||
$definition->{tableKey} = 'testId';
|
||||
$definition->{sequenceKey} = 'assetId';
|
||||
my $properties = $definition->{properties};
|
||||
my $i18n = WebGUI::International->new($session);
|
||||
$properties->{assetId} = {
|
||||
fieldType => 'hidden',
|
||||
defaultValue => undef,
|
||||
};
|
||||
$properties->{name} = {
|
||||
fieldType => 'text',
|
||||
label => $i18n->get( 'test name', 'Asset_Survey' ),
|
||||
hoverHelp => $i18n->get( 'test name help', 'Asset_Survey' ),
|
||||
defaultValue => '',
|
||||
};
|
||||
$properties->{test} = {
|
||||
fieldType => 'codearea',
|
||||
label => $i18n->get( 'test spec', 'Asset_Survey' ),
|
||||
hoverHelp => $i18n->get( 'test spec help', 'Asset_Survey' ),
|
||||
syntax => 'js',
|
||||
defaultValue => <<END_SPEC,
|
||||
[
|
||||
{
|
||||
"name": "My Test",
|
||||
"test": {
|
||||
"variable1": "yes",
|
||||
"next": "section2",
|
||||
},
|
||||
},
|
||||
]
|
||||
END_SPEC
|
||||
};
|
||||
return $definition;
|
||||
}
|
||||
|
||||
=head2 run
|
||||
|
||||
Run this test. Returns TAP in a hashref.
|
||||
|
||||
=cut
|
||||
|
||||
sub run {
|
||||
my $self = shift;
|
||||
my %opts = validate(@_, { responseId => 0 });
|
||||
my $session = $self->session;
|
||||
|
||||
if ( !$session->config->get('enableSurveyExpressionEngine') ) {
|
||||
return { tap => 'Bail Out! enableSurveyExpressionEngine config option disabled' };
|
||||
}
|
||||
|
||||
my $spec = $self->get('test')
|
||||
or return { tap => "Bail Out! Test spec undefined" };
|
||||
|
||||
# Use JSON::PP rather than JSON::XS so that we can use things like allow_barekey
|
||||
my $json = JSON::PP->new->relaxed->allow_barekey->allow_singlequote;
|
||||
eval {
|
||||
$spec = $json->decode($spec); # N.B. This will change to from_json when JSON upgraded to >=2.14
|
||||
# $spec = from_json($spec, { relaxed => 1} );
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
my $error = $@;
|
||||
# $error =~ s/(.*?) at .*/$1/s; # don't reveal too much
|
||||
return { tap => "Bail Out! Invalid test spec: $error" };
|
||||
}
|
||||
|
||||
my $assetId = $self->get('assetId');
|
||||
my $survey = WebGUI::Asset::Wobject::Survey->new($session, $assetId);
|
||||
if (!$survey || !$survey->isa('WebGUI::Asset::Wobject::Survey') ) {
|
||||
return { tap => "Bail Out! Unable to instantiate Survey using assetId: $assetId" };
|
||||
}
|
||||
|
||||
my $responseId = $opts{responseId};
|
||||
|
||||
# Remove existing responses for current user
|
||||
if (!$responseId) {
|
||||
$self->session->db->write( 'delete from Survey_response where assetId = ? and userId = ?',
|
||||
[ $self->getId, $self->session->user->userId() ] );
|
||||
|
||||
# Start a response as current user
|
||||
$responseId = $survey->responseId( { userId => $self->session->user->userId } )
|
||||
or return { tap => "Bail Out! Unable to start survey response" };
|
||||
}
|
||||
|
||||
# Prepare the ingredients..
|
||||
my $rJSON = $survey->responseJSON
|
||||
or return { tap => "Bail Out! Unable to get responseJSON" };
|
||||
|
||||
# Run the tests
|
||||
my $testCount = 0;
|
||||
my @tap;
|
||||
for my $item (@$spec) {
|
||||
$rJSON->reset( {preserveSurveyOrder => 1});
|
||||
my $name = $item->{name};
|
||||
my $setup = $item->{setup};
|
||||
|
||||
# N.B. we pass setup to individual test rather than running it for test, because
|
||||
# some test subs reset rJSON between sub-tests
|
||||
|
||||
my $args;
|
||||
if ($args = $item->{test} ) {
|
||||
push @tap, $self->_test( {
|
||||
responseJSON => $rJSON,
|
||||
args => $args,
|
||||
testCount_ref => \$testCount,
|
||||
name => $name,
|
||||
setup => $setup,
|
||||
} );
|
||||
}
|
||||
elsif ($args = $item->{test_mc} ) {
|
||||
push @tap, $self->_test_mc( {
|
||||
responseJSON => $rJSON,
|
||||
args => $args,
|
||||
testCount_ref => \$testCount,
|
||||
name => $name,
|
||||
setup => $setup,
|
||||
} );
|
||||
}
|
||||
elsif ($args = $item->{sequence} ) {
|
||||
push @tap, $self->_sequence( {
|
||||
responseJSON => $rJSON,
|
||||
args => $args,
|
||||
testCount_ref => \$testCount,
|
||||
name => $name,
|
||||
} );
|
||||
}
|
||||
elsif ($args = $item->{defined} ) {
|
||||
push @tap, $self->_defined( {
|
||||
responseJSON => $rJSON,
|
||||
args => $args,
|
||||
testCount_ref => \$testCount,
|
||||
name => $name,
|
||||
} );
|
||||
}
|
||||
else {
|
||||
push @tap, "Bail Out! Invalid test definition";
|
||||
}
|
||||
}
|
||||
|
||||
$survey->persistResponseJSON;
|
||||
|
||||
my $tap = "1..$testCount\n";
|
||||
$tap .= join "\n", @tap;
|
||||
return { tap => "$tap" };
|
||||
}
|
||||
|
||||
=head2 _test
|
||||
|
||||
Private sub. Triggered when a test spec requests "test".
|
||||
|
||||
In the test spec, keys without special meaning are assumed to be question/section vars.
|
||||
The "next" key is special, indicating what section/question you expect the survey to
|
||||
end up at after responses have been submitted.
|
||||
|
||||
=cut
|
||||
|
||||
sub _test {
|
||||
my $self = shift;
|
||||
my %opts = validate(@_, {
|
||||
responseJSON => { isa => 'WebGUI::Asset::Wobject::Survey::ResponseJSON' },
|
||||
testCount_ref => { type => SCALARREF },
|
||||
args => { type => HASHREF },
|
||||
name => 0,
|
||||
setup => 1,
|
||||
});
|
||||
|
||||
# assemble the top-level ingredients..
|
||||
my $rJSON = $opts{responseJSON};
|
||||
my $args = $opts{args};
|
||||
my $name = $opts{name};
|
||||
my $setup = $opts{setup} || $args->{setup}; # Setup option can also appear inside of test definition
|
||||
my $testCount = ++${$opts{testCount_ref}};
|
||||
|
||||
# ..and the test-specific arguments
|
||||
my ($next, $tagged, $score, $page) = @{$args}{qw(next tagged score page)};
|
||||
delete $args->{next};
|
||||
delete $args->{tagged};
|
||||
delete $args->{score};
|
||||
delete $args->{page};
|
||||
delete $args->{setup};
|
||||
# n.b. everything left in %args assumed to be variable => answer_spec
|
||||
|
||||
if (!$next && !$tagged && !$score && !$page && !$setup && scalar(%$args) == 0 ) {
|
||||
return fail($testCount, "Nothing to do");
|
||||
}
|
||||
|
||||
if ($page) {
|
||||
# Recursively call ourselves (ignoring the returned TAP), so that rJSON gets
|
||||
# updated with responses, simulating the page spec happening in the past
|
||||
my $fakeTestCount = 0;
|
||||
$self->_test( {
|
||||
responseJSON => $rJSON,
|
||||
testCount_ref => \$fakeTestCount,
|
||||
args => $page,
|
||||
setup => $setup,
|
||||
} );
|
||||
}
|
||||
|
||||
# Run setup
|
||||
$self->_setup( { responseJSON => $rJSON, setup => $setup } );
|
||||
|
||||
# Record responses
|
||||
my $responses = {};
|
||||
my $lowestIndex;
|
||||
my $surveyOrder = $rJSON->surveyOrder;
|
||||
my $multipleChoiceTypes = $rJSON->survey->multipleChoiceTypes;
|
||||
delete $multipleChoiceTypes->{Tagged}; # Don't treat Tagged as mc question type
|
||||
while ( my ( $variable, $spec ) = each %$args ) {
|
||||
my $index = $rJSON->surveyOrderIndex($variable);
|
||||
return fail($testCount, "Invalid question variable (1): $variable") if !defined $index;
|
||||
my $address = $surveyOrder->[$index];
|
||||
my $question = $rJSON->survey->question($address);
|
||||
return fail($testCount, "Invalid question variable (2): $variable") if !defined $question;
|
||||
my $questionType = $question->{questionType};
|
||||
|
||||
# Keep track of lowest index (to work out what survey page we should test on)
|
||||
$lowestIndex = $index if (!defined $lowestIndex || $index < $lowestIndex);
|
||||
|
||||
# Goal now is to figure out what answer(s) we are supposed to record
|
||||
if (!defined $spec) {
|
||||
$self->session->log->debug("Spec undefined, assuming that means ignore answer value");
|
||||
} elsif (exists $multipleChoiceTypes->{$questionType}) {
|
||||
# Multi-choice question, so spec is the raw text of the answer we want
|
||||
my $answer;
|
||||
my $aIndex = 0;
|
||||
my $answerAddress;
|
||||
# Iterate over all answers to find the matching
|
||||
for my $a (@{$question->{answers}}) {
|
||||
if ($a->{text} =~ m/\Q$spec\E/i) {
|
||||
$answerAddress = "$address->[0]-$address->[1]-$aIndex";
|
||||
$answer = $a;
|
||||
last;
|
||||
}
|
||||
$aIndex++;
|
||||
}
|
||||
if (!$answer) {
|
||||
return fail($testCount, "determine answer for $variable", "No answers matched text: '$spec'");
|
||||
}
|
||||
$self->session->log->debug("Recording $variable ($answerAddress) => $answer->{recordedAnswer}");
|
||||
$responses->{$answerAddress} = 1;
|
||||
} elsif ( $questionType eq 'Year Month' ) {
|
||||
# Handle YearMonth delicately
|
||||
if ($spec !~ m/\d{4} \w+/) {
|
||||
return fail($testCount, "Invalid input for Year Month question type", "got: $spec\nExpected: YYYY Month");
|
||||
}
|
||||
$responses->{"$address->[0]-$address->[1]-0"} = $spec;
|
||||
} else {
|
||||
# Assume spec is raw value to record in the 0th answer
|
||||
$responses->{"$address->[0]-$address->[1]-0"} = $spec;
|
||||
}
|
||||
}
|
||||
|
||||
my ($pageSection, $pageQuestion);
|
||||
if (defined $lowestIndex) {
|
||||
my $address = $surveyOrder->[$lowestIndex] or return fail($testCount, "Unable to determine address from lowest index: $lowestIndex");
|
||||
$rJSON->nextResponse($lowestIndex);
|
||||
$pageSection = $rJSON->survey->section($surveyOrder->[$lowestIndex]);
|
||||
$pageQuestion = $rJSON->survey->question($surveyOrder->[$lowestIndex]);
|
||||
}
|
||||
|
||||
if (!$name) {
|
||||
$name = "Checking ";
|
||||
my %what = ( next => $next, tagged => $tagged, score => $score );
|
||||
$name .= join ' and ', (grep {$what{$_}} qw(next tagged score));
|
||||
$name .= " on page containing Section $pageSection->{variable}" if $pageSection;
|
||||
$name .= " Question $pageQuestion->{variable}" if $pageQuestion;
|
||||
}
|
||||
|
||||
return $self->_recordResponses( {
|
||||
responseJSON => $rJSON,
|
||||
responses => $responses,
|
||||
next => $next,
|
||||
tagged => $tagged,
|
||||
score => $score,
|
||||
testCount => $testCount,
|
||||
name => $name,
|
||||
});
|
||||
}
|
||||
|
||||
=head2 _setup
|
||||
|
||||
Private sub. Used to setup tags etc.. on a ResponseJSON instance prior to tests being run.
|
||||
|
||||
=cut
|
||||
|
||||
sub _setup {
|
||||
my $self = shift;
|
||||
my %opts = validate(@_, {
|
||||
responseJSON => { isa => 'WebGUI::Asset::Wobject::Survey::ResponseJSON' },
|
||||
setup => 1,
|
||||
});
|
||||
|
||||
my ($rJSON, $setup) = @opts{'responseJSON', 'setup'};
|
||||
|
||||
# Setup any fake data the user wants prior to the test
|
||||
if ($setup && ref $setup eq 'HASH') {
|
||||
# Process tags
|
||||
my %tags;
|
||||
if (ref $setup->{tag} eq 'HASH') {
|
||||
%tags = %{$setup->{tag}};
|
||||
} elsif (ref $setup->{tag} eq 'ARRAY') {
|
||||
for my $tag (@{$setup->{tag}}) {
|
||||
if (ref $tag eq 'HASH') {
|
||||
# Individual item is a single key/value hash
|
||||
my ($key, $value) = %$tag;
|
||||
$tags{$key} = $value;
|
||||
} else {
|
||||
# Individual item is a string, default to boolean truth flag
|
||||
$tags{$tag} = 1; # default to 1
|
||||
}
|
||||
}
|
||||
}
|
||||
# N.B. Make sure we add to existing tags instead of overwriting
|
||||
@{$rJSON->tags}{keys %tags} = values %tags;
|
||||
}
|
||||
}
|
||||
|
||||
=head2 _test_mc
|
||||
|
||||
Private sub. Triggered when a test spec requests "test_mc".
|
||||
|
||||
In the test spec, the first item is a section/question, and all remaining items are definitions
|
||||
of what you expect to happen next.
|
||||
|
||||
=cut
|
||||
|
||||
sub _test_mc {
|
||||
my $self = shift;
|
||||
my %opts = validate(@_, {
|
||||
responseJSON => { isa => 'WebGUI::Asset::Wobject::Survey::ResponseJSON' },
|
||||
testCount_ref => { type => SCALARREF },
|
||||
args => { type => ARRAYREF },
|
||||
name => 0,
|
||||
setup => 1,
|
||||
});
|
||||
|
||||
# assemble the top-level ingredients..
|
||||
my $rJSON = $opts{responseJSON};
|
||||
my $args = $opts{args};
|
||||
my $setup = $opts{setup};
|
||||
|
||||
# the first item is the section/question
|
||||
my $variable = shift @$args;
|
||||
# ..and all remaining items are the specs
|
||||
my @specs = @$args;
|
||||
|
||||
my $surveyOrder = $rJSON->surveyOrder;
|
||||
my $index = $rJSON->surveyOrderIndex($variable);
|
||||
return fail(-1, "Invalid question variable (3): $variable") if !defined $index;
|
||||
my $address = $surveyOrder->[$index];
|
||||
my $question = $rJSON->survey->question($address);
|
||||
return fail(-1, "Invalid question variable (4): $variable") if !defined $question;
|
||||
my $answers = $question->{answers};
|
||||
|
||||
# Each spec is a sub-test, one per answer in the question
|
||||
my @tap;
|
||||
my $aIndex = 0;
|
||||
for my $spec (@specs) {
|
||||
|
||||
# Reset responses between sub-tests
|
||||
$rJSON->reset( {preserveSurveyOrder => 1});
|
||||
|
||||
# Run setup (per-sub-test)
|
||||
$self->_setup( { responseJSON => $rJSON, setup => $setup } );
|
||||
|
||||
# Test runs from $variable
|
||||
$rJSON->nextResponse($index);
|
||||
|
||||
my $responses = {};
|
||||
my $testCount = ++${$opts{testCount_ref}};
|
||||
|
||||
my ($next, $tagged, $score);
|
||||
if (ref $spec eq 'HASH') {
|
||||
($next, $tagged, $score) = @{$spec}{qw(next tagged score)};
|
||||
} else {
|
||||
$next = $spec;
|
||||
}
|
||||
|
||||
my $answerAddress = "$address->[0]-$address->[1]-$aIndex";
|
||||
my $answer = $answers->[$aIndex];
|
||||
$responses->{$answerAddress} = 1;
|
||||
|
||||
my $name = $opts{name}; # get this fresh for every subtest
|
||||
if ($name) {
|
||||
# Add some extra diagnostic text since single test_mc generates multiple sub-tests
|
||||
$name .= " mc answer " . ($aIndex + 1);
|
||||
} else {
|
||||
$name = "Checking ";
|
||||
my %what = ( next => $next, tagged => $tagged, score => $score );
|
||||
$name .= join ' and ', (grep {$what{$_}} qw(next tagged score));
|
||||
$name .= " for $variable mc answer " . ($aIndex + 1);
|
||||
}
|
||||
|
||||
$self->session->log->debug("Choosing mc question $variable answer index $aIndex ($answerAddress)");
|
||||
push @tap, $self->_recordResponses( {
|
||||
responseJSON => $rJSON,
|
||||
responses => $responses,
|
||||
next => $next,
|
||||
testCount => $testCount,
|
||||
name => $name,
|
||||
tagged => $tagged,
|
||||
score => $score,
|
||||
});
|
||||
|
||||
$aIndex++;
|
||||
}
|
||||
return @tap;
|
||||
}
|
||||
|
||||
=head2 _test
|
||||
|
||||
Private sub. Triggered when a test spec requests "sequence".
|
||||
|
||||
=cut
|
||||
|
||||
sub _sequence {
|
||||
my $self = shift;
|
||||
my %opts = validate(@_, {
|
||||
responseJSON => { isa => 'WebGUI::Asset::Wobject::Survey::ResponseJSON' },
|
||||
testCount_ref => { type => SCALARREF },
|
||||
args => { type => HASHREF },
|
||||
name => 0,
|
||||
});
|
||||
|
||||
# assemble the top-level ingredients..
|
||||
my $rJSON = $opts{responseJSON};
|
||||
my $args = $opts{args};
|
||||
my $name = $opts{name} || 'Valid sequences';
|
||||
my $testCount = ++${$opts{testCount_ref}};
|
||||
|
||||
# n.b. everything in %args assumed to be variable => spec
|
||||
my $surveyOrder = $rJSON->surveyOrder;
|
||||
while ( my ( $variable, $spec ) = each %$args ) {
|
||||
my $index = $rJSON->surveyOrderIndex($variable);
|
||||
return fail($testCount, "Invalid question variable (5): $variable") if !defined $index;
|
||||
my $address = $surveyOrder->[$index];
|
||||
my $question = $rJSON->survey->question($address);
|
||||
return fail($testCount, "Invalid question variable (6): $variable") if !defined $question;
|
||||
my $questionType = $question->{questionType};
|
||||
|
||||
# Iterate over all answers
|
||||
my ($recordedAnswer, $score);
|
||||
my $recordedAnswerDelta
|
||||
= $spec->{recordedAnswer} =~ m/desc/ ? -1
|
||||
: $spec->{recordedAnswer} =~ m/asc/ ? 1
|
||||
: $spec->{recordedAnswer} =~ m/cons/ ? 0
|
||||
: undef;
|
||||
|
||||
my $scoreDelta
|
||||
= $spec->{score} =~ m/desc/ ? -1
|
||||
: $spec->{score} =~ m/asc/ ? 1
|
||||
: $spec->{score} =~ m/cons/ ? 0
|
||||
: undef;
|
||||
|
||||
my $aNum = 0;
|
||||
for my $a (@{$question->{answers}}) {
|
||||
$aNum++;
|
||||
|
||||
if (defined $recordedAnswerDelta && defined $recordedAnswer) {
|
||||
my $expect = $recordedAnswer + $recordedAnswerDelta;
|
||||
if ( $expect != $a->{recordedAnswer}) {
|
||||
return fail($testCount, "$variable answer index $aNum recordedAnswer not in sequence", "got: $a->{recordedAnswer}\nExpected: $expect");
|
||||
}
|
||||
}
|
||||
|
||||
if (defined $scoreDelta && defined $score) {
|
||||
my $expect = $score + $scoreDelta;
|
||||
if ( $expect != $a->{value}) {
|
||||
return fail($testCount, "$variable answer index $aNum score not in sequence", "got: $a->{value}\nExpected: $expect");
|
||||
}
|
||||
}
|
||||
|
||||
$recordedAnswer = $a->{recordedAnswer};
|
||||
$score = $a->{value};
|
||||
}
|
||||
}
|
||||
|
||||
return pass($testCount, $name);
|
||||
}
|
||||
|
||||
=head2 _defined
|
||||
|
||||
Private sub. Triggered when a test spec requests "defined".
|
||||
|
||||
=cut
|
||||
|
||||
sub _defined {
|
||||
my $self = shift;
|
||||
my %opts = validate(@_, {
|
||||
responseJSON => { isa => 'WebGUI::Asset::Wobject::Survey::ResponseJSON' },
|
||||
testCount_ref => { type => SCALARREF },
|
||||
args => { type => HASHREF },
|
||||
name => 0,
|
||||
});
|
||||
|
||||
# assemble the top-level ingredients..
|
||||
my $rJSON = $opts{responseJSON};
|
||||
my $args = $opts{args};
|
||||
my $name = $opts{name} || 'Defined';
|
||||
my $testCount = ++${$opts{testCount_ref}};
|
||||
|
||||
# n.b. everything in %args assumed to be regex => spec
|
||||
|
||||
while ( my ( $regex, $spec ) = each %$args ) {
|
||||
my $r = qr/$regex/;
|
||||
for my $question (@{$rJSON->survey->questions}) {
|
||||
my $variable = $question->{variable};
|
||||
if ($variable =~ $r) {
|
||||
# Currently only supports answer specs
|
||||
my $answerSpec = $spec->{answer};
|
||||
my $aNum = 0;
|
||||
for my $answer (@{$question->{answers}}) {
|
||||
$aNum++;
|
||||
for my $property (@$answerSpec) {
|
||||
if (!defined $answer->{$property} || $answer->{$property} =~ m/^\s*$/) {
|
||||
return fail($testCount, "$variable answer number $aNum property $property not defined", "got: '$answer->{$property}'");
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return pass($testCount, $name);
|
||||
}
|
||||
|
||||
=head2 _recordResponses
|
||||
|
||||
Private sub. Records responses and checks that you end up where you expect
|
||||
|
||||
=cut
|
||||
|
||||
sub _recordResponses {
|
||||
my $self = shift;
|
||||
my %opts = validate(@_, {
|
||||
responseJSON => { isa => 'WebGUI::Asset::Wobject::Survey::ResponseJSON' },
|
||||
responses => { type => HASHREF },
|
||||
next => 0,
|
||||
testCount => 1,
|
||||
name => 0,
|
||||
tagged => 0,
|
||||
score => 0,
|
||||
});
|
||||
|
||||
# assemble the top-level ingredients..
|
||||
my $rJSON = $opts{responseJSON};
|
||||
my $responses = $opts{responses};
|
||||
my $next = $opts{next};
|
||||
my $testCount = $opts{testCount};
|
||||
my $name = $opts{name};
|
||||
my $tagged = $opts{tagged};
|
||||
my $score = $opts{score};
|
||||
|
||||
$rJSON->recordResponses($responses);
|
||||
my $surveyOrder = $rJSON->surveyOrder;
|
||||
|
||||
# Check where we end up, if asked
|
||||
if ($next) {
|
||||
my $nextResponse = $rJSON->nextResponse;
|
||||
my $nextAddress = $surveyOrder->[$nextResponse];
|
||||
if ($next ne 'SURVEY_END' && !defined $nextAddress) {
|
||||
return fail($testCount, $name, <<END_WHY);
|
||||
Compared next section/question
|
||||
got : Survey finished
|
||||
expect : '$next'
|
||||
END_WHY
|
||||
}
|
||||
if ($next eq 'SURVEY_END' && !defined $nextAddress) {
|
||||
$self->session->log->debug("SURVEY_END matched correctly");
|
||||
} else {
|
||||
my $nextSection = $rJSON->survey->section($nextAddress);
|
||||
my $nextQuestion = $rJSON->survey->question($nextAddress);
|
||||
# Get the lowest section surveyOrderIndex from lookup
|
||||
my $got;
|
||||
my $svar = $nextSection->{variable};
|
||||
my $qvar = $nextQuestion->{variable};
|
||||
if ($rJSON->surveyOrderIndex($svar) == $nextResponse) {
|
||||
$got = "'$svar' (<-- a section)";
|
||||
$got .= " and '$qvar' (<-- a question)" if $qvar;
|
||||
} elsif ($qvar) {
|
||||
$got = "'$qvar' (<-- a question)";
|
||||
} else {
|
||||
$got = 'Unknown!';
|
||||
}
|
||||
my $expectedNextResponse = $rJSON->surveyOrderIndex($next);
|
||||
if ($nextResponse != $expectedNextResponse) {
|
||||
return fail($testCount, $name, <<END_WHY);
|
||||
Compared next section/question
|
||||
got : $got
|
||||
expect : '$next'
|
||||
END_WHY
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Check tagged, if asked
|
||||
local $Data::Dumper::Sortkeys = 1;
|
||||
# Since tags are often boolean flags, allow them to optionally be specified as an array
|
||||
if ($tagged && ref $tagged eq 'ARRAY') {
|
||||
my $currentTags = $rJSON->tags;
|
||||
for my $tag (@$tagged) {
|
||||
my ($tagKey, $tagValue);
|
||||
if (ref $tag eq 'HASH') {
|
||||
($tagKey, $tagValue) = %$tag; # individual tag spec only has one key and one value
|
||||
} else {
|
||||
($tagKey, $tagValue) = ($tag, 1); # defaults to 1 (boolean truth flag)
|
||||
}
|
||||
if (!exists $currentTags->{$tagKey}) {
|
||||
$self->session->log->debug("Tag not found: $tagKey");
|
||||
return fail($testCount, $name, "Tag not found: $tagKey");
|
||||
}
|
||||
my $currentTagValue = $currentTags->{$tagKey};
|
||||
|
||||
if (!eq_deeply($currentTagValue, $tagValue)) {
|
||||
my $reason = "Compared tag: $tagKey\n" . get_differences($currentTagValue, $tagValue);
|
||||
$reason .= "\nIn..\ngot: " . Dumper($currentTagValue);
|
||||
$reason .= "\nexpect: " . Dumper($tagValue);
|
||||
$self->session->log->debug("Incorrect tag value: $reason");
|
||||
return fail($testCount, $name, $reason);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Alternatively, tags can be a hash
|
||||
if ($tagged && ref $tagged eq 'HASH') {
|
||||
my $currentTags = $rJSON->tags;
|
||||
while (my ($tagKey, $tagValue) = each %$tagged) {
|
||||
my $currentTagValue = $currentTags->{$tagKey};
|
||||
if (!eq_deeply($currentTagValue, $tagValue)) {
|
||||
my $reason = "Compared tag: $tagKey\n" . get_differences($currentTagValue, $tagValue);
|
||||
$reason .= "\nIn..\ngot: " . Dumper($currentTagValue);
|
||||
$reason .= "\nexpect: " . Dumper($tagValue);
|
||||
$self->session->log->debug("Incorrect tag value: $reason");
|
||||
return fail($testCount, $name, $reason);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Check score, if asked
|
||||
if ($score && ref $score eq 'HASH') {
|
||||
my $currentScores = $rJSON->responseScores( indexBy => 'variable' );
|
||||
while (my ($scoreKey, $scoreValue) = each %$score) {
|
||||
my $currentScore = $currentScores->{$scoreKey};
|
||||
if ($currentScore != $scoreValue) {
|
||||
$self->session->log->debug("Incorrect score: $currentScore != $scoreValue");
|
||||
return fail($testCount, $name, <<END_WHY);
|
||||
Compared score '$scoreKey'
|
||||
got : '$currentScore'
|
||||
expect : '$scoreValue'
|
||||
END_WHY
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return pass($testCount, $name);
|
||||
}
|
||||
|
||||
=head2 get_differences
|
||||
|
||||
Once L<Test::Deep::NoTest> > 0.1 is in the WRE, this sub can be replaced with
|
||||
L<cmp_deeply> and L<deep_diag>.
|
||||
|
||||
=cut
|
||||
|
||||
sub get_differences {
|
||||
my ($a, $b) = @_;
|
||||
|
||||
if (!ref $a && !ref $b) {
|
||||
return <<END_WHY;
|
||||
got : '$a'
|
||||
expect : '$b'
|
||||
END_WHY
|
||||
}
|
||||
if (ref $a ne ref $b) {
|
||||
return ref $a . ' does not match ' . ref $b;
|
||||
}
|
||||
if (ref $a eq 'ARRAY') {
|
||||
return "Array lengths differ" if @$a != @$b;
|
||||
for my $i (0 .. $#$a) {
|
||||
if (!eq_deeply($a->[$i], $b->[$i])) {
|
||||
return "Array item at index $i differs\n" . get_differences($a->[$i], $b->[$i]);
|
||||
}
|
||||
}
|
||||
}
|
||||
if (ref $a eq 'HASH') {
|
||||
for my $key (keys %$a, keys %$b) {
|
||||
if (!eq_deeply($a->{$key}, $b->{$key})) {
|
||||
return <<END_WHY
|
||||
Hashes differ on element: $key
|
||||
got : '$a->{$key}'
|
||||
expect : '$b->{$key}'
|
||||
END_WHY
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 pass
|
||||
|
||||
Output TAP for a passing test.
|
||||
|
||||
=cut
|
||||
|
||||
sub pass {
|
||||
my ($testCount, $name, $extra) = @_;
|
||||
my $out = $name ? "ok $testCount - $name" : "ok $testCount";
|
||||
if ($extra) {
|
||||
$extra =~ s/^/# /gm;
|
||||
$out .= "\n$extra";
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 fail
|
||||
|
||||
Output TAP for a failing test, along with diagnostics.
|
||||
|
||||
=cut
|
||||
|
||||
sub fail {
|
||||
my ($testCount, $name, $extra) = @_;
|
||||
my $out = $name ? "not ok $testCount - $name" : "not ok $testCount";
|
||||
if ($extra) {
|
||||
chomp($extra);
|
||||
$extra =~ s/^/# /gm;
|
||||
$out .= "\n$extra";
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
1;
|
||||
Loading…
Add table
Add a link
Reference in a new issue