Survey NYTProf performance improvements
initSurveyOrder now builds a lookup cache to speed up branching Test suite caches surveyOrder and response itself Unnecessary sub calls reduced Updated tests My largest survey instance test suite, which contains > 1000 tests, now runs nearly 8 times faster.
This commit is contained in:
Patrick Donelan
parent
d14cf19e9d
commit
beff1d2166
5 changed files with 134 additions and 166 deletions
|
|
@ -2728,6 +2728,15 @@ sub www_runTests {
|
|||
return $self->session->privilege->insufficient()
|
||||
unless $self->session->user->isInGroup( $self->get('groupToEditSurvey') );
|
||||
|
||||
# Manage response ourselves rather than doing it over and over per-test
|
||||
$self->session->db->write( 'delete from Survey_response where assetId = ? and userId = ?',
|
||||
[ $self->getId, $self->session->user->userId() ] );
|
||||
my $responseId = $self->responseId($self->session->user->userId)
|
||||
or return $self->www_editTestSuite('Unable to start survey response');
|
||||
|
||||
# Also initSurveyOrder ourselves once, and then preserve, rather than re-loading
|
||||
$self->responseJSON->initSurveyOrder;
|
||||
|
||||
my $all = WebGUI::Asset::Wobject::Survey::Test->getAllIterator($session, { sequenceKeyValue => $self->getId } );
|
||||
|
||||
# Expose TAP::Parser::Aggregate info as template variables
|
||||
|
|
@ -2744,7 +2753,8 @@ sub www_runTests {
|
|||
$aggregate->start;
|
||||
|
||||
while (my $test = $all->()) {
|
||||
my $result = $test->run or return $self->www_editTestSuite('Unable to run test: ' . $test->getId);
|
||||
my $result = $test->run( { responseId => $responseId })
|
||||
or return $self->www_editTestSuite('Unable to run test: ' . $test->getId);
|
||||
my $tap = $result->{tap} or return $self->www_editTestSuite('Unable to determine test result: ' . $test->getId);
|
||||
my $name = $test->get('name') || "Unnamed";
|
||||
my $parsed = $self->parseTap($tap);
|
||||
|
|
|
|||
|
|
@ -45,6 +45,7 @@ use strict;
|
|||
use JSON;
|
||||
use Params::Validate qw(:all);
|
||||
use List::Util qw(shuffle);
|
||||
use Clone qw/clone/;
|
||||
use Safe;
|
||||
Params::Validate::validation_options( on_fail => sub { WebGUI::Error::InvalidParam->throw( error => shift ) } );
|
||||
|
||||
|
|
@ -82,7 +83,7 @@ sub new {
|
|||
};
|
||||
|
||||
bless $self, $class;
|
||||
$self->reset($jsonData);
|
||||
$self->reset({ data => $jsonData });
|
||||
}
|
||||
|
||||
=head2 reset
|
||||
|
|
@ -93,7 +94,14 @@ Reset all response data in this object (e.g. re-init the _response property)
|
|||
|
||||
sub reset {
|
||||
my $self = shift;
|
||||
my ($data) = validate_pos(@_, { type => HASHREF, default => {} } );
|
||||
my (%opts) = validate(@_, { data => { type => HASHREF, default => {} }, preserveSurveyOrder => 0 } );
|
||||
|
||||
my $data = $opts{data};
|
||||
|
||||
# Access these via the private hash var so that we don't inadvertantly trigger initSurveyOrder
|
||||
my $oldSurveyOrder = $self->{_response}{surveyOrder};
|
||||
my $oldSurveyOrderLookup = $self->{_response}{surveyOrderLookup};
|
||||
|
||||
$self->{_response} = {
|
||||
# Response hash defaults..
|
||||
responses => {},
|
||||
|
|
@ -107,8 +115,14 @@ sub reset {
|
|||
# And then data overrides (via a hash slice)
|
||||
@{$self->{_response}}{keys %{$data}} = values %{$data};
|
||||
|
||||
if ($opts{preserveSurveyOrder}) {
|
||||
$self->{_response}{surveyOrder} = $oldSurveyOrder;
|
||||
$self->{_response}{surveyOrderLookup} = $oldSurveyOrderLookup;
|
||||
}
|
||||
|
||||
# If first section is logical, process it immediately
|
||||
$self->checkForLogicalSection;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
|
@ -120,6 +134,8 @@ Computes and stores the order of Sections, Questions and Aswers for this Survey.
|
|||
See L<"surveyOrder">. You normally don't need to call this, as L<"surveyOrder"> will
|
||||
call it for you the first time it is used.
|
||||
|
||||
Also builds a lookup table for surveyOrder index, for performance reasons.
|
||||
|
||||
Questions and Answers that are set to be randomized are shuffled into a random order.
|
||||
|
||||
=cut
|
||||
|
|
@ -127,13 +143,22 @@ Questions and Answers that are set to be randomized are shuffled into a random o
|
|||
sub initSurveyOrder {
|
||||
my $self = shift;
|
||||
|
||||
# Build a lookup table as we go
|
||||
my %lookup;
|
||||
|
||||
# Order Questions in each Section
|
||||
my @surveyOrder;
|
||||
my $surveyOrderIndex = 0;
|
||||
for my $sIndex ( 0 .. $self->survey->lastSectionIndex ) {
|
||||
|
||||
my $s = $self->survey->section( [$sIndex] );
|
||||
|
||||
if (my $variable = $s->{variable}) {
|
||||
$lookup{$variable} = $surveyOrderIndex if !exists $lookup{$variable};
|
||||
}
|
||||
|
||||
# Randomize Questions if required..
|
||||
my @qOrder;
|
||||
if ( $self->survey->section( [$sIndex] )->{randomizeQuestions} ) {
|
||||
if ( $s->{randomizeQuestions} ) {
|
||||
@qOrder = shuffle 0 .. $self->survey->lastQuestionIndex( [$sIndex] );
|
||||
}
|
||||
else {
|
||||
|
|
@ -141,25 +166,33 @@ sub initSurveyOrder {
|
|||
}
|
||||
|
||||
# Order Answers in each Question
|
||||
for my $q (@qOrder) {
|
||||
|
||||
for my $qIndex (@qOrder) {
|
||||
|
||||
my $question = $self->survey->question( [ $sIndex, $qIndex ] );
|
||||
if (my $variable = $question->{variable}) {
|
||||
$lookup{$variable} = $surveyOrderIndex if !exists $lookup{$variable};
|
||||
}
|
||||
|
||||
# Randomize Answers if required..
|
||||
my @aOrder;
|
||||
if ( $self->survey->question( [ $sIndex, $q ] )->{randomizeAnswers} ) {
|
||||
@aOrder = shuffle 0 .. $self->survey->lastAnswerIndex( [ $sIndex, $q ] );
|
||||
if ( $question->{randomizeAnswers} ) {
|
||||
@aOrder = shuffle 0 .. $self->survey->lastAnswerIndex( [ $sIndex, $qIndex ] );
|
||||
}
|
||||
else {
|
||||
@aOrder = ( 0 .. $self->survey->lastAnswerIndex( [ $sIndex, $q ] ) );
|
||||
@aOrder = ( 0 .. $self->survey->lastAnswerIndex( [ $sIndex, $qIndex ] ) );
|
||||
}
|
||||
push @surveyOrder, [ $sIndex, $q, \@aOrder ];
|
||||
push @surveyOrder, [ $sIndex, $qIndex, \@aOrder ];
|
||||
$surveyOrderIndex++; # Increment each time an item is pushed onto @surveyOrder
|
||||
}
|
||||
|
||||
# If Section had no Questions, make sure it is still added to @surveyOrder
|
||||
if ( !@qOrder ) {
|
||||
push @surveyOrder, [$sIndex];
|
||||
$surveyOrderIndex++; # Increment each time an item is pushed onto @surveyOrder
|
||||
}
|
||||
}
|
||||
$self->response->{surveyOrder} = \@surveyOrder;
|
||||
$self->response->{surveyOrderLookup} = \%lookup;
|
||||
|
||||
return;
|
||||
}
|
||||
|
|
@ -352,47 +385,27 @@ sub surveyOrder {
|
|||
return $self->response->{surveyOrder};
|
||||
}
|
||||
|
||||
=head2 surveyOrderIndex ($variable)
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
Looks up the surveyOrder index of Section/Question via variable name
|
||||
|
||||
=head2 surveyOrderIndexByVariableName
|
||||
|
||||
Returns a lookup table of variable names to surveyOrder index
|
||||
|
||||
Only questions with a defined variable name set are included.
|
||||
Uses the surveyOrderLookup table, which gets lazily built if it doesn't exist
|
||||
|
||||
=cut
|
||||
|
||||
sub surveyOrderIndexByVariableName {
|
||||
sub surveyOrderIndex {
|
||||
my $self = shift;
|
||||
my $variable = shift;
|
||||
|
||||
my %lookup;
|
||||
|
||||
# Iterate over items in surveyOrder..
|
||||
my $i = 0;
|
||||
for my $address ( @{ $self->surveyOrder } ) {
|
||||
next if !$address;
|
||||
|
||||
# Retreive the section and question for this address..
|
||||
my $section = $self->survey->section($address);
|
||||
my $question = $self->survey->question($address);
|
||||
|
||||
if (my $var = $section && $section->{variable} ) {
|
||||
# Section variables appear for every question, only store lowest index
|
||||
if (!exists $lookup{$var} || $lookup{$var} > $i) {
|
||||
$lookup{$var} = $i;
|
||||
}
|
||||
}
|
||||
|
||||
if (my $var = $question && $question->{variable} ) {
|
||||
$lookup{$var} = $i;
|
||||
}
|
||||
|
||||
# Increment the item index counter
|
||||
$i++;
|
||||
if (!defined $self->response->{surveyOrderLookup}) {
|
||||
$self->initSurveyOrder();
|
||||
}
|
||||
|
||||
return \%lookup;
|
||||
if ($variable) {
|
||||
return $self->response->{surveyOrderLookup}{$variable};
|
||||
} else {
|
||||
return clone $self->response->{surveyOrderLookup};
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
@ -651,12 +664,12 @@ sub recordResponses {
|
|||
next if !$validAnswers{$aId};
|
||||
|
||||
# Answer goto
|
||||
if (my $action = $self->processGoto($answer->{goto})) {
|
||||
if (my $action = $answer->{goto} && $self->processGoto($answer->{goto})) {
|
||||
$self->session->log->debug("Branching on Answer goto: $answer->{goto}");
|
||||
return $action;
|
||||
}
|
||||
# Then answer gotoExpression
|
||||
if (my $action = $self->processExpression($answer->{gotoExpression})) {
|
||||
if (my $action = $answer->{gotoExpression} && $self->processExpression($answer->{gotoExpression})) {
|
||||
$self->session->log->debug("Branching on Answer gotoExpression: $answer->{gotoExpression}");
|
||||
return $action;
|
||||
}
|
||||
|
|
@ -670,12 +683,12 @@ sub recordResponses {
|
|||
# Then Questions..
|
||||
|
||||
# Question goto
|
||||
if (my $action = $self->processGoto($question->{goto})) {
|
||||
if (my $action = $question->{goto} && $self->processGoto($question->{goto})) {
|
||||
$self->session->log->debug("Branching on Question goto: $question->{goto}");
|
||||
return $action;
|
||||
}
|
||||
# Then question gotoExpression
|
||||
if (my $action = $self->processExpression($question->{gotoExpression})) {
|
||||
if (my $action = $question->{gotoExpression} && $self->processExpression($question->{gotoExpression})) {
|
||||
$self->session->log->debug("Branching on Question gotoExpression: $question->{gotoExpression}");
|
||||
return $action;
|
||||
}
|
||||
|
|
@ -685,12 +698,12 @@ sub recordResponses {
|
|||
# Then Sections..
|
||||
|
||||
# Section goto
|
||||
if (my $action = $self->processGoto($section->{goto})) {
|
||||
if (my $action = $section->{goto} && $self->processGoto($section->{goto})) {
|
||||
$self->session->log->debug("Branching on Section goto: $section->{goto}");
|
||||
return $action;
|
||||
}
|
||||
# Then section gotoExpression
|
||||
if (my $action = $self->processExpression($section->{gotoExpression})) {
|
||||
if (my $action = $section->{gotoExpression} && $self->processExpression($section->{gotoExpression})) {
|
||||
$self->session->log->debug("Branching on Section gotoExpression: $section->{gotoExpression}");
|
||||
return $action;
|
||||
}
|
||||
|
|
@ -765,36 +778,13 @@ sub processGoto {
|
|||
$self->checkForLogicalSection;
|
||||
return 1;
|
||||
}
|
||||
|
||||
# Iterate over items in order..
|
||||
my $itemIndex = 0;
|
||||
for my $address (@{ $self->surveyOrder }) {
|
||||
|
||||
# Retreive the section and question for this address..
|
||||
my $section = $self->survey->section( $address );
|
||||
my $question = $self->survey->question( $address );
|
||||
|
||||
# See if our goto variable matches the section variable..
|
||||
if ( ref $section eq 'HASH' && $section->{variable} eq $goto ) {
|
||||
|
||||
# Fudge lastResponse so that the next response item will be our matching item
|
||||
$self->lastResponse( $itemIndex - 1 );
|
||||
$self->checkForLogicalSection;
|
||||
return 1;
|
||||
}
|
||||
|
||||
# See if our goto variable matches the question variable..
|
||||
if ( ref $question eq 'HASH' && $question->{variable} eq $goto ) {
|
||||
|
||||
# Fudge lastResponse so that the next response item will be our matching item
|
||||
$self->lastResponse( $itemIndex - 1 );
|
||||
$self->checkForLogicalSection;
|
||||
return 1;
|
||||
}
|
||||
|
||||
# Increment the item index counter
|
||||
$itemIndex++;
|
||||
|
||||
if (defined(my $surveyOrderIndex = $self->surveyOrderIndex($goto))) {
|
||||
$self->nextResponse( $surveyOrderIndex );
|
||||
$self->checkForLogicalSection;
|
||||
return 1;
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
|
|
@ -993,10 +983,11 @@ sub responseScoresByVariableName {
|
|||
my $self = shift;
|
||||
|
||||
my %lookup;
|
||||
my $responses = $self->responses;
|
||||
# Process responses in id order, just to be consistent with responseValuesByVariableName
|
||||
for my $address (sort keys %{$self->responses}) {
|
||||
for my $address (sort keys %$responses) {
|
||||
next if !$address;
|
||||
my $response = $self->responses->{$address};
|
||||
my $response = $responses->{$address};
|
||||
next if !$response;
|
||||
|
||||
# Turn responses s-q-a string into an address array
|
||||
|
|
@ -1022,16 +1013,13 @@ sub responseScoresByVariableName {
|
|||
}
|
||||
|
||||
# Add section score totals
|
||||
for my $s (@{$self->survey->sections}) {
|
||||
next unless $s->{variable};
|
||||
for my $s ( @{ $self->survey->sections } ) {
|
||||
my $sVar = $s->{variable};
|
||||
next unless $sVar;
|
||||
|
||||
my $score = 0;
|
||||
for my $q (@{$s->{questions}}) {
|
||||
next unless $q->{variable};
|
||||
next unless exists $lookup{$q->{variable}};
|
||||
|
||||
$lookup{$s->{variable}} += $lookup{$q->{variable}};
|
||||
}
|
||||
# N.B. Using map and grep here proved to be about twice as fast as looping over $s->{questions}
|
||||
map { $lookup{$sVar} += $lookup{ $_->{variable} } }
|
||||
grep { $_->{variable} and exists $lookup{ $_->{variable} } } @{ $s->{questions} };
|
||||
}
|
||||
|
||||
return \%lookup;
|
||||
|
|
|
|||
|
|
@ -102,6 +102,7 @@ Run this test. Returns TAP in a hashref.
|
|||
|
||||
sub run {
|
||||
my $self = shift;
|
||||
my %opts = validate(@_, { responseId => 0 });
|
||||
my $session = $self->session;
|
||||
|
||||
if ( !$session->config->get('enableSurveyExpressionEngine') ) {
|
||||
|
|
@ -115,6 +116,7 @@ sub run {
|
|||
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 ($@) {
|
||||
|
|
@ -129,26 +131,27 @@ sub run {
|
|||
return { tap => "Bail Out! Unable to instantiate Survey using assetId: $assetId" };
|
||||
}
|
||||
|
||||
# Remove existing responses for current user
|
||||
$self->session->db->write( 'delete from Survey_response where assetId = ? and userId = ?',
|
||||
[ $self->getId, $self->session->user->userId() ] );
|
||||
my $responseId = $opts{responseId};
|
||||
|
||||
# Start a response as current user
|
||||
my $responseId = $survey->responseId($self->session->user->userId)
|
||||
or return { tap => "Bail Out! Unable to start survey response" };
|
||||
# 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($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" };
|
||||
|
||||
my $surveyOrder = $rJSON->surveyOrder;
|
||||
my $surveyOrderIndexByVariableName = $rJSON->surveyOrderIndexByVariableName;
|
||||
|
||||
# Run the tests
|
||||
my $testCount = 0;
|
||||
my @tap;
|
||||
for my $item (@$spec) {
|
||||
$rJSON->reset;
|
||||
$rJSON->reset( {preserveSurveyOrder => 1});
|
||||
my $name = $item->{name};
|
||||
my $setup = $item->{setup};
|
||||
|
||||
|
|
@ -159,8 +162,6 @@ sub run {
|
|||
if ($args = $item->{test} ) {
|
||||
push @tap, $self->_test( {
|
||||
responseJSON => $rJSON,
|
||||
surveyOrder => $surveyOrder,
|
||||
surveyOrderIndexByVariableName => $surveyOrderIndexByVariableName,
|
||||
args => $args,
|
||||
testCount_ref => \$testCount,
|
||||
name => $name,
|
||||
|
|
@ -170,8 +171,6 @@ sub run {
|
|||
elsif ($args = $item->{test_mc} ) {
|
||||
push @tap, $self->_test_mc( {
|
||||
responseJSON => $rJSON,
|
||||
surveyOrder => $surveyOrder,
|
||||
surveyOrderIndexByVariableName => $surveyOrderIndexByVariableName,
|
||||
args => $args,
|
||||
testCount_ref => \$testCount,
|
||||
name => $name,
|
||||
|
|
@ -181,8 +180,6 @@ sub run {
|
|||
elsif ($args = $item->{sequence} ) {
|
||||
push @tap, $self->_sequence( {
|
||||
responseJSON => $rJSON,
|
||||
surveyOrder => $surveyOrder,
|
||||
surveyOrderIndexByVariableName => $surveyOrderIndexByVariableName,
|
||||
args => $args,
|
||||
testCount_ref => \$testCount,
|
||||
name => $name,
|
||||
|
|
@ -191,8 +188,6 @@ sub run {
|
|||
elsif ($args = $item->{defined} ) {
|
||||
push @tap, $self->_defined( {
|
||||
responseJSON => $rJSON,
|
||||
surveyOrder => $surveyOrder,
|
||||
surveyOrderIndexByVariableName => $surveyOrderIndexByVariableName,
|
||||
args => $args,
|
||||
testCount_ref => \$testCount,
|
||||
name => $name,
|
||||
|
|
@ -224,8 +219,6 @@ sub _test {
|
|||
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,
|
||||
|
|
@ -234,8 +227,6 @@ sub _test {
|
|||
|
||||
# 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 $setup = $opts{setup} || $args->{setup}; # Setup option can also appear inside of test definition
|
||||
|
|
@ -260,8 +251,6 @@ sub _test {
|
|||
my $fakeTestCount = 0;
|
||||
$self->_test( {
|
||||
responseJSON => $rJSON,
|
||||
surveyOrder => $surveyOrder,
|
||||
surveyOrderIndexByVariableName => $surveyOrderIndexByVariableName,
|
||||
testCount_ref => \$fakeTestCount,
|
||||
args => $page,
|
||||
setup => $setup,
|
||||
|
|
@ -274,13 +263,13 @@ sub _test {
|
|||
# Record responses
|
||||
my $responses = {};
|
||||
my $lowestIndex;
|
||||
|
||||
my $surveyOrder = $rJSON->surveyOrder;
|
||||
while ( my ( $variable, $spec ) = each %$args ) {
|
||||
my $index = $surveyOrderIndexByVariableName->{$variable};
|
||||
return fail($testCount, "Invalid question variable: $variable") if !defined $index;
|
||||
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: $variable") if !defined $question;
|
||||
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)
|
||||
|
|
@ -340,8 +329,6 @@ sub _test {
|
|||
return $self->_recordResponses( {
|
||||
responseJSON => $rJSON,
|
||||
responses => $responses,
|
||||
surveyOrder => $surveyOrder,
|
||||
surveyOrderIndexByVariableName => $surveyOrderIndexByVariableName,
|
||||
next => $next,
|
||||
tagged => $tagged,
|
||||
score => $score,
|
||||
|
|
@ -401,8 +388,6 @@ sub _test_mc {
|
|||
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 => ARRAYREF },
|
||||
name => 0,
|
||||
|
|
@ -411,8 +396,6 @@ sub _test_mc {
|
|||
|
||||
# assemble the top-level ingredients..
|
||||
my $rJSON = $opts{responseJSON};
|
||||
my $surveyOrder = $opts{surveyOrder};
|
||||
my $surveyOrderIndexByVariableName = $opts{surveyOrderIndexByVariableName};
|
||||
my $args = $opts{args};
|
||||
my $setup = $opts{setup};
|
||||
|
||||
|
|
@ -421,11 +404,12 @@ sub _test_mc {
|
|||
# ..and all remaining items are the specs
|
||||
my @specs = @$args;
|
||||
|
||||
my $index = $surveyOrderIndexByVariableName->{$variable};
|
||||
return fail(-1, "Invalid question variable: $variable") if !defined $index;
|
||||
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: $variable") if !defined $question;
|
||||
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
|
||||
|
|
@ -434,7 +418,7 @@ sub _test_mc {
|
|||
for my $spec (@specs) {
|
||||
|
||||
# Reset responses between sub-tests
|
||||
$rJSON->reset;
|
||||
$rJSON->reset( {preserveSurveyOrder => 1});
|
||||
|
||||
# Run setup (per-sub-test)
|
||||
$self->_setup( { responseJSON => $rJSON, setup => $setup } );
|
||||
|
|
@ -471,8 +455,6 @@ sub _test_mc {
|
|||
push @tap, $self->_recordResponses( {
|
||||
responseJSON => $rJSON,
|
||||
responses => $responses,
|
||||
surveyOrder => $surveyOrder,
|
||||
surveyOrderIndexByVariableName => $surveyOrderIndexByVariableName,
|
||||
next => $next,
|
||||
testCount => $testCount,
|
||||
name => $name,
|
||||
|
|
@ -495,8 +477,6 @@ 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,
|
||||
|
|
@ -504,20 +484,18 @@ sub _sequence {
|
|||
|
||||
# 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} || '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 = $surveyOrderIndexByVariableName->{$variable};
|
||||
return fail($testCount, "Invalid question variable: $variable") if !defined $index;
|
||||
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: $variable") if !defined $question;
|
||||
return fail($testCount, "Invalid question variable (6): $variable") if !defined $question;
|
||||
my $questionType = $question->{questionType};
|
||||
|
||||
# Iterate over all answers
|
||||
|
|
@ -570,8 +548,6 @@ sub _defined {
|
|||
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,
|
||||
|
|
@ -579,8 +555,6 @@ sub _defined {
|
|||
|
||||
# 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} || 'Defined';
|
||||
my $testCount = ++${$opts{testCount_ref}};
|
||||
|
|
@ -621,8 +595,6 @@ sub _recordResponses {
|
|||
my %opts = validate(@_, {
|
||||
responseJSON => { isa => 'WebGUI::Asset::Wobject::Survey::ResponseJSON' },
|
||||
responses => { type => HASHREF },
|
||||
surveyOrder => { type => ARRAYREF },
|
||||
surveyOrderIndexByVariableName => { type => HASHREF },
|
||||
next => 0,
|
||||
testCount => 1,
|
||||
name => 0,
|
||||
|
|
@ -633,8 +605,6 @@ sub _recordResponses {
|
|||
# assemble the top-level ingredients..
|
||||
my $rJSON = $opts{responseJSON};
|
||||
my $responses = $opts{responses};
|
||||
my $surveyOrder = $opts{surveyOrder};
|
||||
my $surveyOrderIndexByVariableName = $opts{surveyOrderIndexByVariableName};
|
||||
my $next = $opts{next};
|
||||
my $testCount = $opts{testCount};
|
||||
my $name = $opts{name};
|
||||
|
|
@ -642,7 +612,8 @@ sub _recordResponses {
|
|||
my $score = $opts{score};
|
||||
|
||||
$rJSON->recordResponses($responses);
|
||||
|
||||
my $surveyOrder = $rJSON->surveyOrder;
|
||||
|
||||
# Check where we end up, if asked
|
||||
if ($next) {
|
||||
my $nextResponse = $rJSON->nextResponse;
|
||||
|
|
@ -663,7 +634,7 @@ END_WHY
|
|||
my $got;
|
||||
my $svar = $nextSection->{variable};
|
||||
my $qvar = $nextQuestion->{variable};
|
||||
if ($surveyOrderIndexByVariableName->{$svar} == $nextResponse) {
|
||||
if ($rJSON->surveyOrderIndex($svar) == $nextResponse) {
|
||||
$got = "'$svar' (<-- a section)";
|
||||
$got .= " and '$qvar' (<-- a question)" if $qvar;
|
||||
} elsif ($qvar) {
|
||||
|
|
@ -671,7 +642,7 @@ END_WHY
|
|||
} else {
|
||||
$got = 'Unknown!';
|
||||
}
|
||||
my $expectedNextResponse = $surveyOrderIndexByVariableName->{$next};
|
||||
my $expectedNextResponse = $rJSON->surveyOrderIndex($next);
|
||||
if ($nextResponse != $expectedNextResponse) {
|
||||
return fail($testCount, $name, <<END_WHY);
|
||||
Compared next section/question
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue