280e902c09
Fix: Survey export simple/transposed results to csv or tab Fix: loadTempReportTable handling of revisionDates (and documentation) Fix: returnResponseForReporting handling of mc questions NYTProf performance improvements Added some very basic Survey reporting tests
798 lines
26 KiB
Perl
798 lines
26 KiB
Perl
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;
|