Survey: fixed bugs in handling of test setup & Slider question type
This commit is contained in:
Patrick Donelan
parent
8baf09948e
commit
d246454b2f
2 changed files with 162 additions and 46 deletions
|
|
@ -154,8 +154,12 @@ sub run {
|
|||
for my $item (@$spec) {
|
||||
$rJSON->reset;
|
||||
my $name = $item->{name};
|
||||
my $args;
|
||||
if ($args = $item->{test} ) {
|
||||
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
|
||||
|
||||
if (my $args = $item->{test} ) {
|
||||
push @tap, $self->_test( {
|
||||
responseJSON => $rJSON,
|
||||
surveyOrder => $surveyOrder,
|
||||
|
|
@ -163,9 +167,10 @@ sub run {
|
|||
args => $args,
|
||||
testCount_ref => \$testCount,
|
||||
name => $name,
|
||||
setup => $setup,
|
||||
} );
|
||||
}
|
||||
elsif ($args = $item->{test_mc} ) {
|
||||
elsif (my $args = $item->{test_mc} ) {
|
||||
push @tap, $self->_test_mc( {
|
||||
responseJSON => $rJSON,
|
||||
surveyOrder => $surveyOrder,
|
||||
|
|
@ -173,9 +178,10 @@ sub run {
|
|||
args => $args,
|
||||
testCount_ref => \$testCount,
|
||||
name => $name,
|
||||
setup => $setup,
|
||||
} );
|
||||
}
|
||||
elsif ($args = $item->{sequence} ) {
|
||||
elsif (my $args = $item->{sequence} ) {
|
||||
push @tap, $self->_sequence( {
|
||||
responseJSON => $rJSON,
|
||||
surveyOrder => $surveyOrder,
|
||||
|
|
@ -214,6 +220,7 @@ sub _test {
|
|||
testCount_ref => { type => SCALARREF },
|
||||
args => { type => HASHREF },
|
||||
name => 0,
|
||||
setup => 1,
|
||||
});
|
||||
|
||||
# assemble the top-level ingredients..
|
||||
|
|
@ -222,10 +229,11 @@ sub _test {
|
|||
my $surveyOrderIndexByVariableName = $opts{surveyOrderIndexByVariableName};
|
||||
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, $setup ) = @{$args}{qw(next tagged score page setup)};
|
||||
my ($next, $tagged, $score, $page) = @{$args}{qw(next tagged score page)};
|
||||
delete $args->{next};
|
||||
delete $args->{tagged};
|
||||
delete $args->{score};
|
||||
|
|
@ -247,34 +255,12 @@ sub _test {
|
|||
surveyOrderIndexByVariableName => $surveyOrderIndexByVariableName,
|
||||
testCount_ref => \$fakeTestCount,
|
||||
args => $page,
|
||||
setup => $setup,
|
||||
} );
|
||||
}
|
||||
|
||||
# Setup any fake data the user wants prior to the test
|
||||
if ($setup && ref $setup eq 'HASH') {
|
||||
my %existingTags = %{$rJSON->tags};
|
||||
|
||||
# Process tags
|
||||
# N.B. Make sure we add to existing tags instead of overwriting
|
||||
if (ref $setup->{tag} eq 'HASH') {
|
||||
# already a hash, so store it right away
|
||||
$rJSON->tags( {%existingTags, %{$setup->{tag}} });
|
||||
} elsif (ref $setup->{tag} eq 'ARRAY') {
|
||||
# turn array into hash before storing it
|
||||
my $tags;
|
||||
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
|
||||
}
|
||||
}
|
||||
$rJSON->tags( {%existingTags, %$tags });
|
||||
}
|
||||
}
|
||||
# Run setup
|
||||
$self->_setup( { responseJSON => $rJSON, setup => $setup } );
|
||||
|
||||
# Record responses
|
||||
my $responses = {};
|
||||
|
|
@ -293,7 +279,7 @@ sub _test {
|
|||
if (!defined $spec) {
|
||||
$self->session->log->debug("Spec undefined, assuming that means ignore answer value");
|
||||
}
|
||||
elsif ( $questionType eq 'Text' || $questionType eq 'Number' ) {
|
||||
elsif ( $questionType eq 'Text' || $questionType eq 'Number' || $questionType eq 'Slider' ) {
|
||||
# Assume spec is raw value to record in the single answer
|
||||
$responses->{"$address->[0]-$address->[1]-0"} = $spec;
|
||||
} elsif ( $questionType eq 'Year Month' ) {
|
||||
|
|
@ -352,6 +338,48 @@ sub _test {
|
|||
});
|
||||
}
|
||||
|
||||
=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') {
|
||||
my %existingTags = %{$rJSON->tags};
|
||||
|
||||
# Process tags
|
||||
# N.B. Make sure we add to existing tags instead of overwriting
|
||||
if (ref $setup->{tag} eq 'HASH') {
|
||||
# already a hash, so store it right away
|
||||
$rJSON->tags( {%existingTags, %{$setup->{tag}} });
|
||||
} elsif (ref $setup->{tag} eq 'ARRAY') {
|
||||
# turn array into hash before storing it
|
||||
my $tags;
|
||||
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
|
||||
}
|
||||
}
|
||||
$rJSON->tags( {%existingTags, %$tags });
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
=head2 _test_mc
|
||||
|
||||
Private sub. Triggered when a test spec requests "test_mc".
|
||||
|
|
@ -370,6 +398,7 @@ sub _test_mc {
|
|||
testCount_ref => { type => SCALARREF },
|
||||
args => { type => ARRAYREF },
|
||||
name => 0,
|
||||
setup => 1,
|
||||
});
|
||||
|
||||
# assemble the top-level ingredients..
|
||||
|
|
@ -377,6 +406,7 @@ sub _test_mc {
|
|||
my $surveyOrder = $opts{surveyOrder};
|
||||
my $surveyOrderIndexByVariableName = $opts{surveyOrderIndexByVariableName};
|
||||
my $args = $opts{args};
|
||||
my $setup = $opts{setup};
|
||||
|
||||
# the first item is the section/question
|
||||
my $variable = shift @$args;
|
||||
|
|
@ -396,6 +426,9 @@ sub _test_mc {
|
|||
# Reset responses between sub-tests
|
||||
$rJSON->reset;
|
||||
|
||||
# Run setup (per-sub-test)
|
||||
$self->_setup( { responseJSON => $rJSON, setup => $setup } );
|
||||
|
||||
# Test runs from $variable
|
||||
$rJSON->nextResponse($index);
|
||||
|
||||
|
|
@ -465,7 +498,7 @@ sub _sequence {
|
|||
my $surveyOrder = $opts{surveyOrder};
|
||||
my $surveyOrderIndexByVariableName = $opts{surveyOrderIndexByVariableName};
|
||||
my $args = $opts{args};
|
||||
my $name = $opts{name};
|
||||
my $name = $opts{name} || 'Valid sequences';
|
||||
my $testCount = ++${$opts{testCount_ref}};
|
||||
|
||||
# n.b. everything in %args assumed to be variable => spec
|
||||
|
|
@ -513,7 +546,7 @@ sub _sequence {
|
|||
}
|
||||
}
|
||||
|
||||
return pass($testCount, "Valid sequences");
|
||||
return pass($testCount, $name || $name);
|
||||
}
|
||||
|
||||
=head2 _recordResponses
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ my $session = WebGUI::Test->session;
|
|||
|
||||
#----------------------------------------------------------------------------
|
||||
# Tests
|
||||
plan tests => 70;
|
||||
plan tests => 79;
|
||||
|
||||
my ( $s, $t1 );
|
||||
|
||||
|
|
@ -47,9 +47,10 @@ $s->surveyJSON_newObject( [] ); # S2
|
|||
$s->surveyJSON_newObject( [] ); # S3
|
||||
$s->surveyJSON_newObject( [] ); # S4
|
||||
$s->surveyJSON_newObject( [] ); # S5
|
||||
$s->surveyJSON_newObject( [] ); # S6
|
||||
|
||||
# Name the sections
|
||||
for my $sIndex (0..5) {
|
||||
for my $sIndex (0..6) {
|
||||
$s->surveyJSON_update( [$sIndex], { variable => "S$sIndex" } );
|
||||
}
|
||||
|
||||
|
|
@ -61,6 +62,9 @@ $s->surveyJSON_newObject( [3] ); # S3Q0
|
|||
$s->surveyJSON_newObject( [3] ); # S3Q1
|
||||
$s->surveyJSON_newObject( [3] ); # S3Q2
|
||||
$s->surveyJSON_newObject( [4] ); # S4Q0
|
||||
$s->surveyJSON_newObject( [5] ); # S5Q0
|
||||
$s->surveyJSON_newObject( [5] ); # S5Q1
|
||||
$s->surveyJSON_newObject( [5] ); # S5Q2
|
||||
|
||||
# Name the questions
|
||||
$s->surveyJSON_update( [ 0, 0 ], { variable => 'S0Q0' } );
|
||||
|
|
@ -70,6 +74,9 @@ $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( [ 5, 0 ], { variable => 'S5Q0' } );
|
||||
$s->surveyJSON_update( [ 5, 1 ], { variable => 'S5Q1' } );
|
||||
$s->surveyJSON_update( [ 5, 2 ], { variable => 'S5Q2' } );
|
||||
|
||||
# Set additional options..
|
||||
$s->surveyJSON_update( [ 0, 0 ], { questionType => 'Yes/No' } ); # S0Q0 is a Yes/No
|
||||
|
|
@ -87,20 +94,28 @@ for my $qIndex (0..2) {
|
|||
|
||||
$s->surveyJSON_update( [ 4, 0 ], { questionType => 'Concern' } );
|
||||
|
||||
$s->surveyJSON_update( [ 5, 0 ], { questionType => 'Slider', required => 1 } );
|
||||
$s->surveyJSON_update( [ 5, 1 ], { questionType => 'Text', required => 1 } );
|
||||
$s->surveyJSON_update( [ 5, 2 ], { questionType => 'Number', required => 1 } );
|
||||
|
||||
# And finally, persist the changes..
|
||||
$s->persistSurveyJSON;
|
||||
|
||||
cmp_deeply(
|
||||
$s->responseJSON->surveyOrder, [
|
||||
[ 0, 0, [ 0, 1 ] ], # S0Q0
|
||||
[ 1, 0, [ 0, 1 ] ], # S1Q0
|
||||
[ 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'
|
||||
$s->responseJSON->surveyOrder,
|
||||
[ [ 0, 0, [ 0, 1 ] ], # S0Q0
|
||||
[ 1, 0, [ 0, 1 ] ], # S1Q0
|
||||
[ 2, 0, [] ], # S2Q0
|
||||
[ 3, 0, [ 0, 1 ] ], # S3Q0
|
||||
[ 3, 1, [ 0, 1 ] ], # S3Q1
|
||||
[ 3, 2, [ 0, 1 ] ], # S3Q2
|
||||
[ 4, 0, [ 0 .. 10 ] ], # S4Q0
|
||||
[ 5, 0, [0] ], # S5Q0
|
||||
[ 5, 1, [0] ], # S5Q0
|
||||
[ 5, 2, [0] ], # S5Q0
|
||||
[6], # S6
|
||||
],
|
||||
'surveyOrder is correct'
|
||||
);
|
||||
cmp_deeply(
|
||||
$s->responseJSON->surveyOrderIndexByVariableName,
|
||||
|
|
@ -118,6 +133,10 @@ cmp_deeply(
|
|||
'S4' => 6,
|
||||
'S4Q0' => 6,
|
||||
'S5' => 7,
|
||||
'S5Q0' => 7,
|
||||
'S5Q1' => 8,
|
||||
'S5Q2' => 9,
|
||||
'S6' => 10,
|
||||
},
|
||||
'surveyOrderIndexByVariableName correct'
|
||||
);
|
||||
|
|
@ -376,6 +395,24 @@ END_TAP
|
|||
|
||||
# Use the setup option
|
||||
$spec = <<END_SPEC;
|
||||
[
|
||||
{
|
||||
"test" : {
|
||||
"S1Q0" : "n", # sets a tag of its own
|
||||
"page" : { S0Q0: "y" }, # make sure this doesn't get overwritten
|
||||
"tagged" : [ 'tagged at S0Q0', { 'tagged at S1Q0' : 999 }, "my test tag", { "my data tag": 1.5 } ],
|
||||
},
|
||||
"setup" : { tag: [ "my test tag", { "my data tag": 1.5 } ] },
|
||||
},
|
||||
]
|
||||
END_SPEC
|
||||
try_it( $t1, $spec, { tap => <<END_TAP } );
|
||||
1..1
|
||||
ok 1 - Checking tagged on page containing Section S1 Question S1Q0
|
||||
END_TAP
|
||||
|
||||
# setup can also be specified inside test object
|
||||
$spec = <<END_SPEC;
|
||||
[
|
||||
{
|
||||
"test" : {
|
||||
|
|
@ -434,6 +471,24 @@ not ok 4 - Checking tagged on page containing Section S1 Question S1Q0
|
|||
# Tag not found: my data tag
|
||||
END_TAP
|
||||
|
||||
# Slider, Number & Text question types
|
||||
$spec = <<END_SPEC;
|
||||
[
|
||||
{
|
||||
"test" : {
|
||||
"S5Q0" : 5, # Slider
|
||||
"S5Q1" : 'blah', # Text
|
||||
"S5Q2" : 5, # Number
|
||||
"next" : "S6",
|
||||
}
|
||||
},
|
||||
]
|
||||
END_SPEC
|
||||
try_it( $t1, $spec, { tap => <<END_TAP } );
|
||||
1..1
|
||||
ok 1 - Checking next on page containing Section S5 Question S5Q0
|
||||
END_TAP
|
||||
|
||||
#########
|
||||
# test_mc
|
||||
#########
|
||||
|
|
@ -493,6 +548,27 @@ ok 1 - Checking next and tagged for S0Q0 mc answer 1
|
|||
ok 2 - Checking next for S0Q0 mc answer 2
|
||||
END_TAP
|
||||
|
||||
# use the setup option
|
||||
$spec = <<END_SPEC;
|
||||
[
|
||||
{
|
||||
"test_mc" : [
|
||||
"S0Q0", # test S0Q0
|
||||
{ "next" : "S1Q0", # first answer falls through
|
||||
"tagged" : [ "tagged at S0Q0", 'blah' ], # and tagged data
|
||||
},
|
||||
{ "next" : "S1" }, # second answer falls through to the same place
|
||||
],
|
||||
setup : { tag: [ "blah" ] },
|
||||
}
|
||||
]
|
||||
END_SPEC
|
||||
try_it( $t1, $spec, { tap => <<END_TAP } );
|
||||
1..2
|
||||
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
|
||||
$spec = <<END_SPEC;
|
||||
[
|
||||
|
|
@ -526,12 +602,19 @@ $spec = <<END_SPEC;
|
|||
"S3Q1" : { "recordedAnswer" : "desc", "score" : "desc" }, # ..set the score on the No answer to zero, hence
|
||||
"S3Q2" : { "recordedAnswer" : "desc", "score" : "desc" }, # ..they are descending
|
||||
}
|
||||
},
|
||||
{
|
||||
"name" : "Say my name",
|
||||
"sequence" : {
|
||||
"S3Q2" : { "recordedAnswer" : "desc", "score" : "desc" }, # ..they are descending
|
||||
}
|
||||
}
|
||||
]
|
||||
END_SPEC
|
||||
try_it( $t1, $spec, { tap => <<END_TAP } );
|
||||
1..1
|
||||
1..2
|
||||
ok 1 - Valid sequences
|
||||
ok 2 - Say my name
|
||||
END_TAP
|
||||
|
||||
use TAP::Parser;
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue