Refactored Survey test suite diagnostics etc..
This commit is contained in:
Patrick Donelan
parent
de47c22eff
commit
9cbd30c3d8
4 changed files with 355 additions and 78 deletions
|
|
@ -349,6 +349,18 @@ sub avg {
|
|||
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.
|
||||
|
|
@ -451,6 +463,7 @@ sub run {
|
|||
$compartment->share('&exitUrl');
|
||||
$compartment->share('&restart');
|
||||
$compartment->share('&avg');
|
||||
$compartment->share('&round');
|
||||
|
||||
# Give them all of List::Util too
|
||||
$compartment->share_from( 'List::Util',
|
||||
|
|
|
|||
|
|
@ -148,6 +148,7 @@ sub run {
|
|||
for my $item (@$spec) {
|
||||
$self->_resetResponses($rJSON);
|
||||
$rJSON->lastResponse(-1);
|
||||
my $name = $item->{name};
|
||||
if (my $args = $item->{test} ) {
|
||||
push @tap, $self->_test( {
|
||||
responseJSON => $rJSON,
|
||||
|
|
@ -155,6 +156,7 @@ sub run {
|
|||
surveyOrderIndexByVariableName => $surveyOrderIndexByVariableName,
|
||||
args => $args,
|
||||
testCount_ref => \$testCount,
|
||||
name => $name,
|
||||
} );
|
||||
}
|
||||
elsif (my $args = $item->{test_mc} ) {
|
||||
|
|
@ -164,6 +166,17 @@ sub run {
|
|||
surveyOrderIndexByVariableName => $surveyOrderIndexByVariableName,
|
||||
args => $args,
|
||||
testCount_ref => \$testCount,
|
||||
name => $name,
|
||||
} );
|
||||
}
|
||||
elsif (my $args = $item->{sequence} ) {
|
||||
push @tap, $self->_sequence( {
|
||||
responseJSON => $rJSON,
|
||||
surveyOrder => $surveyOrder,
|
||||
surveyOrderIndexByVariableName => $surveyOrderIndexByVariableName,
|
||||
args => $args,
|
||||
testCount_ref => \$testCount,
|
||||
name => $name,
|
||||
} );
|
||||
}
|
||||
else {
|
||||
|
|
@ -206,6 +219,7 @@ sub _test {
|
|||
surveyOrderIndexByVariableName => { type => HASHREF },
|
||||
testCount_ref => { type => SCALARREF },
|
||||
args => { type => HASHREF },
|
||||
name => 0,
|
||||
});
|
||||
|
||||
# assemble the top-level ingredients..
|
||||
|
|
@ -213,12 +227,14 @@ sub _test {
|
|||
my $surveyOrder = $opts{surveyOrder};
|
||||
my $surveyOrderIndexByVariableName = $opts{surveyOrderIndexByVariableName};
|
||||
my $args = $opts{args};
|
||||
my $name = $opts{name};
|
||||
my $testCount = ++${$opts{testCount_ref}};
|
||||
|
||||
# ..and the test-specific arguments
|
||||
my ($next, $tags, $setup ) = @{$args}{qw(next tags setup)};
|
||||
my ($next, $tagged, $score, $setup ) = @{$args}{qw(next tagged score setup)};
|
||||
delete $args->{next};
|
||||
delete $args->{tags};
|
||||
delete $args->{tagged};
|
||||
delete $args->{score};
|
||||
delete $args->{setup};
|
||||
# n.b. everything left in %args assumed to be variable => answer_spec
|
||||
|
||||
|
|
@ -255,7 +271,13 @@ sub _test {
|
|||
elsif ( $questionType eq 'Text' || $questionType eq 'Number' ) {
|
||||
# Assume spec is raw value to record in the single answer
|
||||
$responses->{"$address->[0]-$address->[1]-0"} = $spec;
|
||||
}
|
||||
} elsif ( $questionType eq 'Year Month' ) {
|
||||
if ($spec !~ m/\d{4} \w+/) {
|
||||
return fail($testCount, "Invalid input for Year Month question type", "Got: $spec\nExpected: YYYY Month");
|
||||
}
|
||||
$self->session->log->debug("Recording Year Month value: $spec");
|
||||
$responses->{"$address->[0]-$address->[1]-0"} = $spec;
|
||||
}
|
||||
else {
|
||||
# Assume spec is the raw text of the answer we want
|
||||
my $answer;
|
||||
|
|
@ -282,10 +304,13 @@ sub _test {
|
|||
|
||||
my $pageSection = $rJSON->survey->section($surveyOrder->[$lowestIndex]);
|
||||
my $pageQuestion = $rJSON->survey->question($surveyOrder->[$lowestIndex]);
|
||||
my $what = "Page containing Section $pageSection->{variable}";
|
||||
$what .= " Question $pageQuestion->{variable}" if $pageQuestion;
|
||||
$what .= " jumps to $next" if $next;
|
||||
$what .= " and tags data" if $tags;
|
||||
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}";
|
||||
$name .= " Question $pageQuestion->{variable}" if $pageQuestion;
|
||||
}
|
||||
|
||||
return $self->_recordResponses( {
|
||||
responseJSON => $rJSON,
|
||||
|
|
@ -293,9 +318,10 @@ sub _test {
|
|||
surveyOrder => $surveyOrder,
|
||||
surveyOrderIndexByVariableName => $surveyOrderIndexByVariableName,
|
||||
next => $next,
|
||||
tags => $tags,
|
||||
tagged => $tagged,
|
||||
score => $score,
|
||||
testCount => $testCount,
|
||||
what => $what,
|
||||
name => $name,
|
||||
});
|
||||
}
|
||||
|
||||
|
|
@ -316,6 +342,7 @@ sub _test_mc {
|
|||
surveyOrderIndexByVariableName => { type => HASHREF },
|
||||
testCount_ref => { type => SCALARREF },
|
||||
args => { type => ARRAYREF },
|
||||
name => 0,
|
||||
});
|
||||
|
||||
# assemble the top-level ingredients..
|
||||
|
|
@ -348,9 +375,9 @@ sub _test_mc {
|
|||
my $responses = {};
|
||||
my $testCount = ++${$opts{testCount_ref}};
|
||||
|
||||
my ($next, $tags);
|
||||
my ($next, $tagged, $score);
|
||||
if (ref $spec eq 'HASH') {
|
||||
($next, $tags) = @{$spec}{qw(next tags)};
|
||||
($next, $tagged, $score) = @{$spec}{qw(next tagged score)};
|
||||
} else {
|
||||
$next = $spec;
|
||||
}
|
||||
|
|
@ -359,10 +386,17 @@ sub _test_mc {
|
|||
my $answer = $answers->[$aIndex];
|
||||
my $recordedAnswer = $answer->{recordedAnswer};
|
||||
$responses->{$answerAddress} = $recordedAnswer;
|
||||
|
||||
my $what = "$variable mc answer " . ($aIndex + 1);
|
||||
$what .= " jumps to $next" if $next;
|
||||
$what .= " and tags correct" if $tags;
|
||||
|
||||
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("Recording answer for mc question $variable at index $aIndex ($answerAddress) => $recordedAnswer");
|
||||
push @tap, $self->_recordResponses( {
|
||||
|
|
@ -372,8 +406,9 @@ sub _test_mc {
|
|||
surveyOrderIndexByVariableName => $surveyOrderIndexByVariableName,
|
||||
next => $next,
|
||||
testCount => $testCount,
|
||||
what => $what,
|
||||
tags => $tags,
|
||||
name => $name,
|
||||
tagged => $tagged,
|
||||
score => $score,
|
||||
});
|
||||
|
||||
$aIndex++;
|
||||
|
|
@ -381,6 +416,79 @@ sub _test_mc {
|
|||
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' },
|
||||
surveyOrder => { type => ARRAYREF },
|
||||
surveyOrderIndexByVariableName => { type => HASHREF },
|
||||
testCount_ref => { type => SCALARREF },
|
||||
args => { type => HASHREF },
|
||||
name => 0,
|
||||
});
|
||||
|
||||
# assemble the top-level ingredients..
|
||||
my $rJSON = $opts{responseJSON};
|
||||
my $surveyOrder = $opts{surveyOrder};
|
||||
my $surveyOrderIndexByVariableName = $opts{surveyOrderIndexByVariableName};
|
||||
my $args = $opts{args};
|
||||
my $name = $opts{name};
|
||||
my $testCount = ++${$opts{testCount_ref}};
|
||||
|
||||
# n.b. everything in %args assumed to be variable => spec
|
||||
|
||||
while ( my ( $variable, $spec ) = each %$args ) {
|
||||
my $index = $surveyOrderIndexByVariableName->{$variable};
|
||||
my $address = $surveyOrder->[$index];
|
||||
my $question = $rJSON->survey->question($address);
|
||||
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, "Valid sequences");
|
||||
}
|
||||
|
||||
=head2 _recordResponses
|
||||
|
||||
Private sub. Records responses and checks that you end up where you expect
|
||||
|
|
@ -396,8 +504,9 @@ sub _recordResponses {
|
|||
surveyOrderIndexByVariableName => { type => HASHREF },
|
||||
next => 1,
|
||||
testCount => 1,
|
||||
what => 0,
|
||||
tags => 0,
|
||||
name => 0,
|
||||
tagged => 0,
|
||||
score => 0,
|
||||
});
|
||||
|
||||
# assemble the top-level ingredients..
|
||||
|
|
@ -407,8 +516,9 @@ sub _recordResponses {
|
|||
my $surveyOrderIndexByVariableName = $opts{surveyOrderIndexByVariableName};
|
||||
my $next = $opts{next};
|
||||
my $testCount = $opts{testCount};
|
||||
my $what = $opts{what};
|
||||
my $tags = $opts{tags};
|
||||
my $name = $opts{name};
|
||||
my $tagged = $opts{tagged};
|
||||
my $score = $opts{score};
|
||||
|
||||
$rJSON->recordResponses($responses);
|
||||
|
||||
|
|
@ -431,30 +541,33 @@ sub _recordResponses {
|
|||
}
|
||||
my $expectedNextResponse = $surveyOrderIndexByVariableName->{$next};
|
||||
if ($nextResponse != $expectedNextResponse) {
|
||||
return fail($testCount, $what, <<END_WHY);
|
||||
return fail($testCount, $name, <<END_WHY);
|
||||
Compared next section/question
|
||||
got : $got
|
||||
expect : '$next'
|
||||
END_WHY
|
||||
}
|
||||
# Check tags, if asked
|
||||
if ($tags && ref $tags eq 'ARRAY') {
|
||||
|
||||
# Check tagged, if asked
|
||||
|
||||
# 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 (@$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
|
||||
($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, $what, "Tag not found: $tagKey");
|
||||
return fail($testCount, $name, "Tag not found: $tagKey");
|
||||
}
|
||||
my $currentTagValue = $currentTags->{$tagKey};
|
||||
if ($currentTagValue != $tagValue) {
|
||||
$self->session->log->debug("Incorrect tag value: $currentTagValue != $tagValue");
|
||||
return fail($testCount, $what, <<END_WHY);
|
||||
return fail($testCount, $name, <<END_WHY);
|
||||
Compared tag '$tagKey'
|
||||
got : '$currentTagValue'
|
||||
expect : '$tagValue'
|
||||
|
|
@ -463,12 +576,44 @@ END_WHY
|
|||
}
|
||||
}
|
||||
|
||||
return pass($testCount, $what);
|
||||
# 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 ($currentTagValue != $tagValue) {
|
||||
$self->session->log->debug("Incorrect tag value: $currentTagValue != $tagValue");
|
||||
return fail($testCount, $name, <<END_WHY);
|
||||
Compared tag '$tagKey'
|
||||
got : '$currentTagValue'
|
||||
expect : '$tagValue'
|
||||
END_WHY
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Check score, if asked
|
||||
if ($score && ref $score eq 'HASH') {
|
||||
my $currentScores = $rJSON->responseScoresByVariableName;
|
||||
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);
|
||||
}
|
||||
|
||||
sub pass {
|
||||
my ($testCount, $what, $extra) = @_;
|
||||
my $out = $what ? "ok $testCount - $what" : "ok $testCount";
|
||||
my ($testCount, $name, $extra) = @_;
|
||||
my $out = $name ? "ok $testCount - $name" : "ok $testCount";
|
||||
if ($extra) {
|
||||
$extra =~ s/^/# /gm;
|
||||
$out .= "\n$extra";
|
||||
|
|
@ -477,8 +622,8 @@ sub pass {
|
|||
}
|
||||
|
||||
sub fail {
|
||||
my ($testCount, $what, $extra) = @_;
|
||||
my $out = $what ? "not ok $testCount - $what" : "not ok $testCount";
|
||||
my ($testCount, $name, $extra) = @_;
|
||||
my $out = $name ? "not ok $testCount - $name" : "not ok $testCount";
|
||||
if ($extra) {
|
||||
chomp($extra);
|
||||
$extra =~ s/^/# /gm;
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ my $session = WebGUI::Test->session;
|
|||
|
||||
#----------------------------------------------------------------------------
|
||||
# Tests
|
||||
my $tests = 56;
|
||||
my $tests = 57;
|
||||
plan tests => $tests + 1;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
|
@ -71,6 +71,7 @@ SKIP: {
|
|||
q{jump { if (value(n) == 5) { 1 } else { 0 } } target}, # if statement
|
||||
q{jump { $q2 = 3; $avg = (value(n) + $q2) / 2; $avg == 4 } target}, # look ma, averages!
|
||||
q{jump { $q2 = 3; avg(value(n), $q2) == 4 } target}, # look ma, built-in avg sub!
|
||||
q{jump { round(3.456) == 3 && round(3.456, 2) == 3.46 } target}, # rounding
|
||||
q{jump { value(n) == 5 } target; jump { value(n) == 5 } targetX}, # first jump wins
|
||||
q{jump { value(n) == 0 } targetX; jump { value(n) == 5 } target}, # false jumps ignored
|
||||
q{jump { min(3,5,2) == 2 } target}, # List::Util min
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ my $session = WebGUI::Test->session;
|
|||
|
||||
#----------------------------------------------------------------------------
|
||||
# Tests
|
||||
plan tests => 34;
|
||||
plan tests => 52;
|
||||
|
||||
my ( $s, $t1 );
|
||||
|
||||
|
|
@ -46,13 +46,12 @@ $s->surveyJSON_newObject( [] ); # S1
|
|||
$s->surveyJSON_newObject( [] ); # S2
|
||||
$s->surveyJSON_newObject( [] ); # S3
|
||||
$s->surveyJSON_newObject( [] ); # S4
|
||||
$s->surveyJSON_newObject( [] ); # S5
|
||||
|
||||
# Name the sections
|
||||
$s->surveyJSON_update( [0], { variable => 'S0' } );
|
||||
$s->surveyJSON_update( [1], { variable => 'S1' } );
|
||||
$s->surveyJSON_update( [2], { variable => 'S2' } );
|
||||
$s->surveyJSON_update( [3], { variable => 'S3' } );
|
||||
$s->surveyJSON_update( [4], { variable => 'S4' } );
|
||||
for my $sIndex (0..5) {
|
||||
$s->surveyJSON_update( [$sIndex], { variable => "S$sIndex" } );
|
||||
}
|
||||
|
||||
# ..and now some questions
|
||||
$s->surveyJSON_newObject( [0] ); # S0Q0
|
||||
|
|
@ -60,8 +59,8 @@ $s->surveyJSON_newObject( [1] ); # S1Q0
|
|||
$s->surveyJSON_newObject( [2] ); # S2Q0
|
||||
$s->surveyJSON_newObject( [3] ); # S3Q0
|
||||
$s->surveyJSON_newObject( [3] ); # S3Q1
|
||||
$s->surveyJSON_newObject( [3] ); # S3Q2
|
||||
$s->surveyJSON_newObject( [4] ); # S4Q0
|
||||
$s->surveyJSON_newObject( [4] ); # S4Q1
|
||||
|
||||
# Name the questions
|
||||
$s->surveyJSON_update( [ 0, 0 ], { variable => 'S0Q0' } );
|
||||
|
|
@ -69,16 +68,24 @@ $s->surveyJSON_update( [ 1, 0 ], { variable => 'S1Q0' } );
|
|||
$s->surveyJSON_update( [ 2, 0 ], { variable => 'S2Q0' } );
|
||||
$s->surveyJSON_update( [ 3, 0 ], { variable => 'S3Q0' } );
|
||||
$s->surveyJSON_update( [ 3, 1 ], { variable => 'S3Q1' } );
|
||||
$s->surveyJSON_update( [ 3, 2 ], { variable => 'S3Q2' } );
|
||||
$s->surveyJSON_update( [ 4, 0 ], { variable => 'S4Q0' } );
|
||||
$s->surveyJSON_update( [ 4, 1 ], { variable => 'S4Q1' } );
|
||||
|
||||
# Set additional options..
|
||||
$s->surveyJSON_update( [ 0, 0 ], { questionType => 'Yes/No' } ); # S0Q0 is a Yes/No
|
||||
$s->surveyJSON_update( [ 0, 0 ], { gotoExpression => q{ tag('tagged at S0Q0'); } } ); # S0Q0 tags data
|
||||
$s->surveyJSON_update( [ 0, 0 ], { gotoExpression => q{ tag('tagged at S0Q0'); } } ); # S0Q0 tagged data
|
||||
|
||||
$s->surveyJSON_update( [ 1, 0 ], { questionType => 'Yes/No' } ); # S1Q0 is a Yes/No
|
||||
$s->surveyJSON_update( [ 1, 0, 0 ], { goto => 'S3' } ); # S1Q0 answer 0 jumps to S3
|
||||
$s->surveyJSON_update( [ 1, 0, 1 ], { gotoExpression => q{ tag('tagged at S1Q0'); } } );# S1Q0 answer 1 tags data
|
||||
$s->surveyJSON_update( [ 1, 0, 1 ], { gotoExpression => q{ tag('tagged at S1Q0', 999); } } );# S1Q0 answer 1 tagged numeric data
|
||||
|
||||
$s->surveyJSON_update( [ 3 ], { gotoExpression => q{ jump { score(S3) == 0 } S5; } } ); # jump to S5 if all 3 questions answered as No
|
||||
for my $qIndex (0..2) {
|
||||
$s->surveyJSON_update( [ 3, $qIndex ], { questionType => 'Yes/No', required => 1 } );
|
||||
$s->surveyJSON_update( [ 3, $qIndex, 1 ], { value => 0 } ); # Set 'No' score to 0
|
||||
}
|
||||
|
||||
$s->surveyJSON_update( [ 4, 0 ], { questionType => 'Concern' } );
|
||||
|
||||
# And finally, persist the changes..
|
||||
$s->persistSurveyJSON;
|
||||
|
|
@ -87,14 +94,14 @@ cmp_deeply(
|
|||
$s->responseJSON->surveyOrder, [
|
||||
[ 0, 0, [ 0, 1 ] ], # S0Q0
|
||||
[ 1, 0, [ 0, 1 ] ], # S1Q0
|
||||
[ 2, 0, [] ], # S2Q0
|
||||
[ 3, 0, [] ], # S3Q0
|
||||
[ 3, 1, [] ], # S3Q1
|
||||
[ 4, 0, [] ], # S4Q0
|
||||
[ 4, 1, [] ], # S4Q1
|
||||
[ 2, 0, [] ], # S2Q0
|
||||
[ 3, 0, [ 0, 1 ] ], # S3Q0
|
||||
[ 3, 1, [ 0, 1 ] ], # S3Q1
|
||||
[ 3, 2, [ 0, 1 ] ], # S3Q2
|
||||
[ 4, 0, [ 0 .. 10 ] ], # S4Q0
|
||||
[ 5 ], # S5
|
||||
], 'surveyOrder is correct'
|
||||
);
|
||||
|
||||
cmp_deeply(
|
||||
$s->responseJSON->surveyOrderIndexByVariableName,
|
||||
{
|
||||
|
|
@ -107,9 +114,10 @@ cmp_deeply(
|
|||
'S3' => 3,
|
||||
'S3Q0' => 3,
|
||||
'S3Q1' => 4,
|
||||
'S4' => 5,
|
||||
'S4Q0' => 5,
|
||||
'S4Q1' => 6,
|
||||
'S3Q2' => 5,
|
||||
'S4' => 6,
|
||||
'S4Q0' => 6,
|
||||
'S5' => 7,
|
||||
},
|
||||
'surveyOrderIndexByVariableName correct'
|
||||
);
|
||||
|
|
@ -140,8 +148,8 @@ $spec = <<END_SPEC;
|
|||
END_SPEC
|
||||
try_it( $t1, $spec, { tap => <<END_TAP } );
|
||||
1..2
|
||||
ok 1 - Page containing Section S0 Question S0Q0 jumps to S1
|
||||
ok 2 - Page containing Section S0 Question S0Q0 jumps to S1Q0
|
||||
ok 1 - Checking next on page containing Section S0 Question S0Q0
|
||||
ok 2 - Checking next on page containing Section S0 Question S0Q0
|
||||
END_TAP
|
||||
|
||||
# deliberately pass in a spec that will fail
|
||||
|
|
@ -157,12 +165,31 @@ $spec = <<END_SPEC;
|
|||
END_SPEC
|
||||
try_it( $t1, $spec, { tap => <<END_TAP, fail => 1 } );
|
||||
1..1
|
||||
not ok 1 - Page containing Section S0 Question S0Q0 jumps to S2
|
||||
not ok 1 - Checking next on page containing Section S0 Question S0Q0
|
||||
# Compared next section/question
|
||||
# got : 'S1' (<-- a section) and 'S1Q0' (<-- a question)
|
||||
# expect : 'S2'
|
||||
END_TAP
|
||||
|
||||
# also fails if we don't answer all required questions
|
||||
$spec = <<END_SPEC;
|
||||
[
|
||||
{
|
||||
"test" : {
|
||||
"S3Q0" : "Yes",
|
||||
"next" : "S4", # fails because we missed S3Q1 and S3Q2
|
||||
}
|
||||
}
|
||||
]
|
||||
END_SPEC
|
||||
try_it( $t1, $spec, { tap => <<END_TAP, fail => 1 } );
|
||||
1..1
|
||||
not ok 1 - Checking next on page containing Section S3 Question S3Q0
|
||||
# Compared next section/question
|
||||
# got : 'S3' (<-- a section) and 'S3Q0' (<-- a question)
|
||||
# expect : 'S4'
|
||||
END_TAP
|
||||
|
||||
# now try it on a question that has branching, and doesn't start on the first page
|
||||
$spec = <<END_SPEC;
|
||||
[
|
||||
|
|
@ -176,24 +203,75 @@ $spec = <<END_SPEC;
|
|||
END_SPEC
|
||||
try_it( $t1, $spec, { tap => <<END_TAP } );
|
||||
1..1
|
||||
ok 1 - Page containing Section S1 Question S1Q0 jumps to S3
|
||||
ok 1 - Checking next on page containing Section S1 Question S1Q0
|
||||
END_TAP
|
||||
|
||||
# Use tags..
|
||||
# use our own description
|
||||
$spec = <<END_SPEC;
|
||||
[
|
||||
{
|
||||
"test" : {
|
||||
"S1Q0" : "Yes",
|
||||
"next" : "S3", # a goto jump
|
||||
},
|
||||
"name" : "my individual test label"
|
||||
},
|
||||
]
|
||||
END_SPEC
|
||||
try_it( $t1, $spec, { tap => <<END_TAP } );
|
||||
1..1
|
||||
ok 1 - my individual test label
|
||||
END_TAP
|
||||
|
||||
## Use tagged..
|
||||
$spec = <<END_SPEC;
|
||||
[
|
||||
{
|
||||
"test" : {
|
||||
"S0Q0" : "Yes",
|
||||
"next" : "S1",
|
||||
"tags" : [ "tagged at S0Q0" ], # and tagged correctly
|
||||
"tagged" : [ "tagged at S0Q0" ], # and tagged correctly
|
||||
}
|
||||
},
|
||||
]
|
||||
END_SPEC
|
||||
try_it( $t1, $spec, { tap => <<END_TAP } );
|
||||
1..1
|
||||
ok 1 - Page containing Section S0 Question S0Q0 jumps to S1 and tags data
|
||||
ok 1 - Checking next and tagged on page containing Section S0 Question S0Q0
|
||||
END_TAP
|
||||
|
||||
# Same but more verbose
|
||||
$spec = <<END_SPEC;
|
||||
[
|
||||
{
|
||||
"test" : {
|
||||
"S0Q0" : "Yes",
|
||||
"next" : "S1",
|
||||
"tagged" : [ { "tagged at S0Q0" : 1 }, ], # and tagged correctly
|
||||
}
|
||||
},
|
||||
]
|
||||
END_SPEC
|
||||
try_it( $t1, $spec, { tap => <<END_TAP } );
|
||||
1..1
|
||||
ok 1 - Checking next and tagged on page containing Section S0 Question S0Q0
|
||||
END_TAP
|
||||
|
||||
# Also the same (uses hash instead of array)
|
||||
$spec = <<END_SPEC;
|
||||
[
|
||||
{
|
||||
"test" : {
|
||||
"S0Q0" : "Yes",
|
||||
"next" : "S1",
|
||||
"tagged" : { "tagged at S0Q0" : 1 },
|
||||
}
|
||||
},
|
||||
]
|
||||
END_SPEC
|
||||
try_it( $t1, $spec, { tap => <<END_TAP } );
|
||||
1..1
|
||||
ok 1 - Checking next and tagged on page containing Section S0 Question S0Q0
|
||||
END_TAP
|
||||
|
||||
# Use setup..
|
||||
|
|
@ -201,17 +279,17 @@ $spec = <<END_SPEC;
|
|||
[
|
||||
{
|
||||
"test" : {
|
||||
"setup" : { "S0Q0" : "Yes" }, # S0Q0 tags 'tagged at S0Q0'
|
||||
"setup" : { "S0Q0" : "Yes" }, # S0Q0 tagged 'tagged at S0Q0'
|
||||
"S1Q0" : "No",
|
||||
"next" : "S2",
|
||||
"tags" : [ "tagged at S0Q0" ], # tagged by setup step
|
||||
"tagged" : [ "tagged at S0Q0" ], # tagged by setup step
|
||||
}
|
||||
},
|
||||
]
|
||||
END_SPEC
|
||||
try_it( $t1, $spec, { tap => <<END_TAP } );
|
||||
1..1
|
||||
ok 1 - Page containing Section S1 Question S1Q0 jumps to S2 and tags data
|
||||
ok 1 - Checking next and tagged on page containing Section S1 Question S1Q0
|
||||
END_TAP
|
||||
|
||||
# Use nested setup..
|
||||
|
|
@ -221,20 +299,39 @@ $spec = <<END_SPEC;
|
|||
"test" : {
|
||||
"setup" : {
|
||||
"setup" : {
|
||||
"S0Q0" : "Yes" # tags 'tagged at S0Q0'
|
||||
"S0Q0" : "Yes" # tagged 'tagged at S0Q0'
|
||||
},
|
||||
"S1Q0" : "No", # tags 'tagged at S1Q0'
|
||||
"S1Q0" : "No", # tagged 'tagged at S1Q0' with value 999
|
||||
},
|
||||
"S2Q0" : null,
|
||||
"next" : "S3",
|
||||
"tags" : [ "tagged at S0Q0", "tagged at S1Q0", ], # tagged by setup step
|
||||
"tagged" : [ "tagged at S0Q0", { "tagged at S1Q0" : 999 }, ], # tagged by setup step
|
||||
}
|
||||
},
|
||||
]
|
||||
END_SPEC
|
||||
try_it( $t1, $spec, { tap => <<END_TAP } );
|
||||
1..1
|
||||
ok 1 - Page containing Section S2 Question S2Q0 jumps to S3 and tags data
|
||||
ok 1 - Checking next and tagged on page containing Section S2 Question S2Q0
|
||||
END_TAP
|
||||
|
||||
# Use the score option
|
||||
$spec = <<END_SPEC;
|
||||
[
|
||||
{
|
||||
"test" : {
|
||||
"S3Q0" : "n",
|
||||
"S3Q1" : "y",
|
||||
"S3Q2" : "y",
|
||||
"next" : "S4",
|
||||
"score" : { "S3" : 2 },
|
||||
}
|
||||
},
|
||||
]
|
||||
END_SPEC
|
||||
try_it( $t1, $spec, { tap => <<END_TAP } );
|
||||
1..1
|
||||
ok 1 - Checking next and score on page containing Section S3 Question S3Q0
|
||||
END_TAP
|
||||
|
||||
#########
|
||||
|
|
@ -254,8 +351,8 @@ $spec = <<END_SPEC;
|
|||
END_SPEC
|
||||
try_it( $t1, $spec, { tap => <<END_TAP } );
|
||||
1..2
|
||||
ok 1 - S0Q0 mc answer 1 jumps to S1Q0
|
||||
ok 2 - S0Q0 mc answer 2 jumps to S1
|
||||
ok 1 - Checking next for S0Q0 mc answer 1
|
||||
ok 2 - Checking next for S0Q0 mc answer 2
|
||||
END_TAP
|
||||
|
||||
# try the same thing, but in a more verbose form
|
||||
|
|
@ -272,18 +369,18 @@ $spec = <<END_SPEC;
|
|||
END_SPEC
|
||||
try_it( $t1, $spec, { tap => <<END_TAP } );
|
||||
1..2
|
||||
ok 1 - S0Q0 mc answer 1 jumps to S1Q0
|
||||
ok 2 - S0Q0 mc answer 2 jumps to S1
|
||||
ok 1 - Checking next for S0Q0 mc answer 1
|
||||
ok 2 - Checking next for S0Q0 mc answer 2
|
||||
END_TAP
|
||||
|
||||
# use the tags option
|
||||
# use the tagged option
|
||||
$spec = <<END_SPEC;
|
||||
[
|
||||
{
|
||||
"test_mc" : [
|
||||
"S0Q0", # test S0Q0
|
||||
{ "next" : "S1Q0", # first answer falls through
|
||||
"tags" : [ "tagged at S0Q0" ], # and tags data
|
||||
"tagged" : [ "tagged at S0Q0" ], # and tagged data
|
||||
},
|
||||
{ "next" : "S1" }, # second answer falls through to the same place
|
||||
]
|
||||
|
|
@ -292,8 +389,8 @@ $spec = <<END_SPEC;
|
|||
END_SPEC
|
||||
try_it( $t1, $spec, { tap => <<END_TAP } );
|
||||
1..2
|
||||
ok 1 - S0Q0 mc answer 1 jumps to S1Q0 and tags correct
|
||||
ok 2 - S0Q0 mc answer 2 jumps to S1
|
||||
ok 1 - Checking next and tagged for S0Q0 mc answer 1
|
||||
ok 2 - Checking next for S0Q0 mc answer 2
|
||||
END_TAP
|
||||
|
||||
# And try one that does branching, and doesn't start on the first page
|
||||
|
|
@ -303,7 +400,7 @@ $spec = <<END_SPEC;
|
|||
"test_mc" : [
|
||||
"S1Q0", # test S1Q0
|
||||
{ "next" : "S3", # first answer jumps
|
||||
"tags" : [ ], # nothing gets tagged
|
||||
"tagged" : [ ], # nothing gets tagged
|
||||
},
|
||||
{ "next" : "S2" }, # second answer falls through
|
||||
]
|
||||
|
|
@ -312,8 +409,29 @@ $spec = <<END_SPEC;
|
|||
END_SPEC
|
||||
try_it( $t1, $spec, { tap => <<END_TAP } );
|
||||
1..2
|
||||
ok 1 - S1Q0 mc answer 1 jumps to S3 and tags correct
|
||||
ok 2 - S1Q0 mc answer 2 jumps to S2
|
||||
ok 1 - Checking next and tagged for S1Q0 mc answer 1
|
||||
ok 2 - Checking next for S1Q0 mc answer 2
|
||||
END_TAP
|
||||
|
||||
#########
|
||||
# sequence
|
||||
#########
|
||||
$spec = <<END_SPEC;
|
||||
[
|
||||
{
|
||||
"sequence" : {
|
||||
"S1Q0" : { "recordedAnswer" : "desc", "score" : "cons" }, # This is a default Yes/No (score all 1)
|
||||
"S4Q0" : { "recordedAnswer" : "asc" }, # Certainty scale, with recordedAnswer 0 .. 11
|
||||
"S3Q0" : { "recordedAnswer" : "desc", "score" : "desc" }, # These 3 are yes/no questions where we have
|
||||
"S3Q1" : { "recordedAnswer" : "desc", "score" : "desc" }, # ..set the score on the No answer to zero, hence
|
||||
"S3Q2" : { "recordedAnswer" : "desc", "score" : "desc" }, # ..they are descending
|
||||
}
|
||||
}
|
||||
]
|
||||
END_SPEC
|
||||
try_it( $t1, $spec, { tap => <<END_TAP } );
|
||||
1..1
|
||||
ok 1 - Valid sequences
|
||||
END_TAP
|
||||
|
||||
use TAP::Parser;
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue