Survey: fixed bugs in handling of test setup & Slider question type

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

@@ -154,8 +154,12 @@ sub run {
     for my $item (@$spec) {
         $rJSON->reset;
         my $name = $item->{name};
-        my $args;
+        my $setup = $item->{setup};
-        if ($args = $item->{test} ) {
+        
+        # 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
+    # Run setup
-    if ($setup && ref $setup eq 'HASH') {
+    $self->_setup( { responseJSON => $rJSON, setup => $setup } );
-        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 });
-        }
-    }
     
     # 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

t/Asset/Wobject/Survey/Test.t

@@ -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, [
+    $s->responseJSON->surveyOrder,
-       [ 0, 0, [ 0, 1 ] ],  # S0Q0
+    [   [ 0, 0, [ 0, 1 ] ],    # S0Q0
-       [ 1, 0, [ 0, 1 ] ],  # S1Q0
+        [ 1, 0, [ 0, 1 ] ],    # S1Q0
-       [ 2, 0, [] ],        # S2Q0
+        [ 2, 0, [] ],          # S2Q0
-       [ 3, 0, [ 0, 1 ] ],  # S3Q0
+        [ 3, 0, [ 0, 1 ] ],    # S3Q0
-       [ 3, 1, [ 0, 1 ] ],  # S3Q1
+        [ 3, 1, [ 0, 1 ] ],    # S3Q1
-       [ 3, 2, [ 0, 1 ] ],  # S3Q2
+        [ 3, 2, [ 0, 1 ] ],    # S3Q2
-       [ 4, 0, [ 0 .. 10 ] ],        # S4Q0
+        [ 4, 0, [ 0 .. 10 ] ], # S4Q0
-       [ 5 ],               # S5
+        [ 5, 0, [0] ],         # S5Q0
-     ], 'surveyOrder is correct'
+        [ 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;