SurveyJSON bug fixes

Fixed bug in SurveyJSON::update to stop it updating questionType when not asked
Fixed unsafe reference bug in SurveyJSON::getMultipleChoiceBundle
Added more Survey Test Suite tests

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

@@ -651,8 +651,8 @@ sub update {
             $newQuestion = 1; # make note that a new question was created
             push @{ $self->questions($address) }, $object;
         }
-        # We need to update all of the answers to reflect the new questionType
+        # If questionType supplied, see if we need to update all of the answers to reflect the new questionType
-        if ( $properties->{questionType} ne $object->{questionType} ) {
+        if ( $properties->{questionType} && $properties->{questionType} ne $object->{questionType} ) {
             $self->updateQuestionAnswers( $address, $properties->{questionType} );
         }
     }
@@ -957,6 +957,11 @@ sub newAnswer {
 
 Remove all existing answers and add a default set of answers to a question, based on question type.
 
+N.B. You probably don't want to call this method directly to update a question's questionType, as it
+doesn't actually change the stored value of questionType. Instead, call:
+
+ $surveyJSON->update( $address, { questionType => "some question type" } );
+
 =head3 $address
 
 See L<"Address Parameter">. Determines question to add answers to.
@@ -1032,7 +1037,8 @@ sub getMultiChoiceBundle {
     my $self = shift;
     my ($type) = validate_pos( @_, { type => SCALAR | UNDEF } );
 
-    return $self->{multipleChoiceTypes}->{$type};
+    # Return a cloned copy of the bundle structure
+    return clone $self->{multipleChoiceTypes}->{$type};
 }
 
 =head2 addAnswersToQuestion ($address, $answers)

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

@@ -305,20 +305,28 @@ sub _test_mc {
     my @tap;
     my $aIndex = 0;
     for my $spec (@specs) {
+        
+        # Reset responses between sub-tests
         $self->_resetResponses($rJSON);
+        
         # Test runs from $variable
         $rJSON->nextResponse($index);
         
         my $responses = {};
         my $testCount = ++${$opts{testCount_ref}};
         
-        # assume spec can only be a target
+        my ($next, $tags);
-        my $next = $spec;
+        if (ref $spec eq 'HASH') {
+            ($next, $tags) = @{$spec}{qw(next tags)};
+        } else {
+            $next = $spec;
+        }
         
         my $answerAddress = "$address->[0]-$address->[1]-$aIndex";
         my $answer = $answers->[$aIndex];
         my $recordedAnswer = $answer->{recordedAnswer};
         $responses->{$answerAddress} = $recordedAnswer;
+        
         $self->session->log->debug("Recording answer for mc question $variable at index $aIndex ($answerAddress) => $recordedAnswer");
         push @tap, $self->_recordResponses( { 
             responseJSON => $rJSON, 
@@ -328,6 +336,7 @@ sub _test_mc {
             next => $next,
             testCount => $testCount,
             what => "$variable mc answer " . ($aIndex + 1) . " jumps to $next",
+            tags => $tags,
         });
         
         $aIndex++;
@@ -351,6 +360,7 @@ sub _recordResponses {
         next => 1,
         testCount => 1,
         what => 0,
+        tags => 0,
     });
     
     # assemble the top-level ingredients..
@@ -361,6 +371,7 @@ sub _recordResponses {
     my $next = $opts{next};
     my $testCount = $opts{testCount};
     my $what = $opts{what};
+    my $tags = $opts{tags};
     
     $rJSON->recordResponses($responses);
 
@@ -369,28 +380,51 @@ sub _recordResponses {
     my $nextAddress = $surveyOrder->[$nextResponse];
     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 ($surveyOrderIndexByVariableName->{$svar} == $nextResponse) {
-        $got = "$svar (<-- a section)";
+        $got = "'$svar' (<-- a section)";
-        $got .= " and $qvar (<-- a question)" if $qvar;
+        $got .= " and '$qvar' (<-- a question)" if $qvar;
     } elsif ($qvar) {
-        $got = "$qvar (<-- a question)";
+        $got = "'$qvar' (<-- a question)";
     } else {
         $got = 'Unknown!';
     }
-    
     my $expectedNextResponse = $surveyOrderIndexByVariableName->{$next};
     if ($nextResponse != $expectedNextResponse) {
         return fail($testCount, $what, <<END_WHY);
 Compared next section/question
    got : $got
-expect : $next
+expect : '$next'
 END_WHY
     }
+    # Check tags, if asked
+    if ($tags && ref $tags eq 'ARRAY') {
+        my $currentTags = $rJSON->tags;
+        for my $tag (@$tags) {
+            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, $what, "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);
+Compared tag '$tagKey'
+   got : '$currentTagValue'
+expect : '$tagValue'
+END_WHY
+            }
+        }
+    }
     
     return pass($testCount, $what);
 }

t/Asset/Wobject/Survey.t

@@ -43,9 +43,9 @@ $survey->surveyJSON_update([0], { variable => 'S0' });
 
 # Add 2 questions to S0
 $survey->surveyJSON_newObject([0]);    # S0Q0
-$survey->surveyJSON_update([0,0], { variable => 'S0Q0' });
+$survey->surveyJSON_update([0,0], { variable => 'S0Q0', questionType => 'Yes/No' });
 $survey->surveyJSON_newObject([0]);    # S0Q1
-$survey->surveyJSON_update([0,1], { variable => 'S0Q1' });
+$survey->surveyJSON_update([0,1], { variable => 'S0Q1', questionType => 'Yes/No' });
 
 # Add a new section (S1)
 $survey->surveyJSON_newObject([]);     # S1
@@ -92,8 +92,8 @@ ok($s->responseId, '..(and similarly for responseId)');
 
 # Restart the survey
 $s->submitQuestions({
-    '0-0-0'        => 'My chosen answer',
+    '0-0-0'        => 'this text ignored',
-    '0-1-0'        => 'My chosen answer',
+    '0-1-0'        => 'this text ignored',
 });
 
 cmp_deeply(
@@ -103,13 +103,13 @@ cmp_deeply(
                 'verbatim' => undef,
                 'comment'  => undef,
                 'time'     => num( time, 5 ),
-                'value'    => ''
+                'value'    => 1
             },
             '0-0-0' => {
                 'verbatim' => undef,
                 'comment'  => undef,
                 'time'     => num( time, 5 ),
-                'value'    => ''
+                'value'    => 1
             },
         }
     ),

t/Asset/Wobject/Survey/Test.t

@@ -21,7 +21,7 @@ my $session = WebGUI::Test->session;
 
 #----------------------------------------------------------------------------
 # Tests
-plan tests => 22;
+plan tests => 25;
 
 my ( $s, $t1 );
 
@@ -39,53 +39,88 @@ isa_ok( $s, 'WebGUI::Asset::Wobject::Survey' );
 
 $s->responseIdCookies(0);
 
-# Load bare-bones survey, containing a single section (S0)
+# N.B. Survey starts off with a single empty section (S0)
+
+# Add some sections and questions
+$s->surveyJSON_newObject( [] ); # S1
+$s->surveyJSON_newObject( [] ); # S2
+$s->surveyJSON_newObject( [] ); # S3
+$s->surveyJSON_newObject( [] ); # S4
+
+# Name the sections
 $s->surveyJSON_update( [0], { variable => 'S0' } );
-$s->surveyJSON_newObject( [0] );
-$s->surveyJSON_newObject( [] );
-$s->surveyJSON_newObject( [1] );
-$s->surveyJSON_newObject( [1] );
-$s->surveyJSON_newObject( [] );
-$s->surveyJSON_newObject( [2] );
-$s->surveyJSON_newObject( [] );
-
-$s->surveyJSON_update( [ 0, 0 ], { variable => 'S0Q0' } );
 $s->surveyJSON_update( [1], { variable => 'S1' } );
-$s->surveyJSON_update( [ 1, 0 ], { variable => 'S1Q0' } );
-$s->surveyJSON_update( [ 1, 1 ], { variable => 'S1Q1' } );
 $s->surveyJSON_update( [2], { variable => 'S2' } );
-$s->surveyJSON_update( [ 2, 0 ], { variable => 'S2Q0' } );
 $s->surveyJSON_update( [3], { variable => 'S3' } );
+$s->surveyJSON_update( [4], { variable => 'S4' } );
 
-$s->surveyJSON->updateQuestionAnswers( [ 0, 0 ], 'Yes/No' );
+# ..and now some questions
-$s->surveyJSON->updateQuestionAnswers( [ 1, 0 ], 'Yes/No' );
+$s->surveyJSON_newObject( [0] ); # S0Q0
-$s->surveyJSON->updateQuestionAnswers( [ 1, 1 ], 'Yes/No' );
+$s->surveyJSON_newObject( [1] ); # S1Q0
+$s->surveyJSON_newObject( [2] ); # S2Q0
+$s->surveyJSON_newObject( [3] ); # S3Q0
+$s->surveyJSON_newObject( [3] ); # S3Q1
+$s->surveyJSON_newObject( [4] ); # S4Q0
+$s->surveyJSON_newObject( [4] ); # S4Q1
 
+# Name the questions
+$s->surveyJSON_update( [ 0, 0 ], { variable => 'S0Q0' } );
+$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( [ 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( [ 1, 0 ], { questionType => 'Yes/No' } ); # S1Q0 is a Yes/No
+$s->surveyJSON_update( [ 1, 0, 0 ], { goto => 'S3' } ); # S1Q0 jumps to S3
+
+# And finally, persist the changes..
 $s->persistSurveyJSON;
 
 cmp_deeply(
-    $s->responseJSON->surveyOrder,
+    $s->responseJSON->surveyOrder, [
-    [ [ 0, 0, [ 0, 1 ] ], [ 1, 0, [0, 1] ], [ 1, 1, [0, 1] ], [ 2, 0, [0] ], [ 3 ] ],
+       [ 0, 0, [ 0, 1 ] ],  # S0Q0
-    'At this stage our surveyOrder has 3 items'
+       [ 1, 0, [ 0, 1 ] ],  # S1Q0
+       [ 2, 0, [] ],     # S2Q0
+       [ 3, 0, [] ],     # S3Q0
+       [ 3, 1, [] ],     # S3Q1
+       [ 4, 0, [] ],     # S4Q0
+       [ 4, 1, [] ],     # S4Q1
+     ], 'surveyOrder is correct'
 );
 
 cmp_deeply(
-    $s->responseJSON->surveyOrderIndexByVariableName,
+    $s->responseJSON->surveyOrderIndexByVariableName, 
-    {   'S0'   => 0,
+    {   
+        'S0'   => 0,
         'S0Q0' => 0,
         'S1'   => 1,
         'S1Q0' => 1,
-        'S1Q1' => 2,
+        'S2'   => 2,
-        'S2'   => 3,
+        'S2Q0' => 2,
-        'S2Q0' => 3,
+        'S3'   => 3,
-        'S3'   => 4,
+        'S3Q0' => 3,
+        'S3Q1' => 4,
+        'S4'   => 5,
+        'S4Q0' => 5,
+        'S4Q1' => 6,
     },
-    '..which corresponds to'
+    'surveyOrderIndexByVariableName correct'
 );
 
 $t1 = WebGUI::Asset::Wobject::Survey::Test->create( $session, { assetId => $s->getId } );
 my $spec;
 
+######
+# test
+######
+
+# Both answers for S0Q0 jump to the next item, which can be referred to as either S1 or S1Q0
 $spec = <<END_SPEC;
 [
     {
@@ -97,7 +132,7 @@ $spec = <<END_SPEC;
     {
        "test" : {
             "S0Q0" : "No",
-            "next" : "S1",
+            "next" : "S1Q0",
        }
     }
 ]
@@ -105,90 +140,121 @@ END_SPEC
 try_it( $t1, $spec, { tap => <<END_TAP } );
 1..2
 ok 1 - jumps to S1
-ok 2 - jumps to S1
+ok 2 - jumps to S1Q0
 END_TAP
 
-# add a goto into the mix
-$s->surveyJSON_update( [ 0, 0, 0 ], { goto => 'S1Q1' } );
-
 # deliberately pass in a spec that will fail
 $spec = <<END_SPEC;
 [
     {
        "test" : {
             "S0Q0" : "Yes",
-            "next" : "S1", # this will fail here, because Yes now jumps to S1Q1
+            "next" : "S2", # wrong target, should fail
-       }
-    },
-    {
-       "test" : {
-            "S0Q0" : "No",
-            "next" : "S1",
        }
     }
 ]
 END_SPEC
 try_it( $t1, $spec, { tap => <<END_TAP, fail => 1 } );
-1..2
+1..1
-not ok 1 - jumps to S1
+not ok 1 - jumps to S2
 # Compared next section/question
-#    got : S1Q1 (<-- a question)
+#    got : 'S1' (<-- a section) and 'S1Q0' (<-- a question)
-# expect : S1
+# expect : 'S2'
-ok 2 - jumps to S1
 END_TAP
 
-# try now with a spec that will pass
+# now try it on a question that has branching, and doesn't start on the first page
 $spec = <<END_SPEC;
 [
     {
        "test" : {
-            "S0Q0" : "Yes",
+            "S1Q0" : "Yes",
-            "next" : "S1Q1", # jumps
+            "next" : "S3", # a goto jumps
        }
     },
-    {
+]
-       "test" : {
+END_SPEC
-            "S0Q0" : "No",
+try_it( $t1, $spec, { tap => <<END_TAP } );
-            "next" : "S1",  # falls through
+1..1
-       }
+ok 1 - jumps to S3
+END_TAP
+
+#########
+# test_mc
+#########
+# Now use test_mc
+$spec = <<END_SPEC;
+[ 
+    { 
+        "test_mc" : [ 
+            "S0Q0",  # from S0Q0
+            "S1Q0",  # first answer falls through
+            "S1",    # second answer falls through to the same place
+        ] 
+    } 
+]
+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
+END_TAP
+
+# try the same thing, but in a more verbose form
+$spec = <<END_SPEC;
+[ 
+    { 
+        "test_mc" : [ 
+            "S0Q0",  # from S0Q0
+            { "next" : "S1Q0" },    # first answer falls through
+            { "next" : "S1"   },    # second answer falls through to the same place
+        ]
     }
 ]
 END_SPEC
 try_it( $t1, $spec, { tap => <<END_TAP } );
 1..2
-ok 1 - jumps to S1Q1
+ok 1 - S0Q0 mc answer 1 jumps to S1Q0
-ok 2 - jumps to S1
-END_TAP
-
-# Now use test_mc
-$spec = q{ [ { "test_mc" : [ "S0Q0", "S1Q1", "S1" ] } ] };
-try_it( $t1, $spec, { tap => <<END_TAP } );
-1..2
-ok 1 - S0Q0 mc answer 1 jumps to S1Q1
 ok 2 - S0Q0 mc answer 2 jumps to S1
 END_TAP
 
-# Now try one that doesn't start on the first page of the survey
+# use the tags option
 $spec = <<END_SPEC;
-[ { "test" : { 
+[ 
-        "S1Q0" : "Yes",
+    { 
-        "S1Q0" : "No",
+        "test_mc" : [ 
-        "next" : "S2", # falls through
+            "S0Q0",                             # test S0Q0
-    } 
+            {   "next" : "S1Q0",                # first answer falls through
-  },
+                "tags" : [ "tagged at S0Q0" ],  # and tags data
+            },    
+            { "next" : "S1" },                  # second answer falls through to the same place
+        ]
+    }
 ]
 END_SPEC
 try_it( $t1, $spec, { tap => <<END_TAP } );
-1..1
+1..2
-ok 1 - jumps to S2
+ok 1 - S0Q0 mc answer 1 jumps to S1Q0
+ok 2 - S0Q0 mc answer 2 jumps to S1
 END_TAP
 
-# And similarly a test_mc one that doesn't start on the first page
+# And try one that does branching, and doesn't start on the first page
-$spec = q{ [ { "test_mc" : [ "S2Q0", "S3", "S3" ] } ] };
+$spec = <<END_SPEC;
+[ 
+    { 
+        "test_mc" : [ 
+            "S1Q0",                             # test S1Q0
+            {   "next" : "S3",                  # first answer jumps
+                "tags" : [ ],                   # nothing gets tagged
+            },
+            { "next" : "S2" },                  # second answer falls through
+        ]
+    }
+]
+END_SPEC
 try_it( $t1, $spec, { tap => <<END_TAP } );
 1..2
-ok 1 - S2Q0 mc answer 1 jumps to S3
+ok 1 - S1Q0 mc answer 1 jumps to S3
-ok 2 - S2Q0 mc answer 2 jumps to S3
+ok 2 - S1Q0 mc answer 2 jumps to S2
 END_TAP
 
 use TAP::Parser;
@@ -219,5 +285,5 @@ sub try_it {
 # Cleanup
 END {
     $s->purge() if $s;
-    $t1->delete();
+    $t1->delete() if $t1;
 }