Survey bug fixes
Fixed bugs in the handling of logical sections, creating of responses and counting of responses. Added in a bunch of new tests. Jslinting of all survye js files
This commit is contained in:
Patrick Donelan
parent
5e7c594440
commit
3a25e806c6
12 changed files with 703 additions and 476 deletions
|
|
@ -662,12 +662,13 @@ sub getAdminConsole {
|
|||
my $self = shift;
|
||||
my $ac = $self->SUPER::getAdminConsole;
|
||||
my $i18n = WebGUI::International->new($self->session, "Asset_Survey");
|
||||
my $edit = WebGUI::International->new($self->session, "WebGUI")->get(575);
|
||||
$ac->addSubmenuItem($self->session->url->page("func=edit"), $edit);
|
||||
$ac->addSubmenuItem($self->session->url->page("func=editSurvey"), "$edit Survey");
|
||||
$ac->addSubmenuItem($self->session->url->page("func=graph"), $i18n->get('survey visualization'));
|
||||
$ac->addSubmenuItem($self->session->url->page("func=edit"), WebGUI::International->new($self->session, "WebGUI")->get(575));
|
||||
$ac->addSubmenuItem($self->session->url->page("func=editSurvey"), $i18n->get('edit survey'));
|
||||
$ac->addSubmenuItem($self->session->url->page("func=takeSurvey"), $i18n->get('take survey'));
|
||||
$ac->addSubmenuItem($self->session->url->page("func=graph"), $i18n->get('visualize'));
|
||||
$ac->addSubmenuItem($self->session->url->page("func=editTestSuite"), $i18n->get("test suite"));
|
||||
$ac->addSubmenuItem($self->session->url->page("func=runTests"), $i18n->get("run all tests"));
|
||||
$ac->addSubmenuItem($self->session->url->page("func=runTests;format=tap"), $i18n->get("run all tests") . " (TAP)");
|
||||
return $ac;
|
||||
}
|
||||
|
||||
|
|
@ -1297,13 +1298,18 @@ A template to use. Defaults to this Survey's feedbackTemplateId
|
|||
|
||||
sub getResponseDetails {
|
||||
my $self = shift;
|
||||
my %opts = validate(@_, { userId => 0, responseId => 0, templateId => 0 } );
|
||||
my %opts = validate(@_, { userId => 0, responseId => 0, templateId => 0, isComplete => 0} );
|
||||
my $responseId = $opts{responseId};
|
||||
my $userId = $opts{userId} || $self->session->user->userId;
|
||||
my $templateId = $opts{templateId} || $self->get('feedbackTemplateId') || 'nWNVoMLrMo059mDRmfOp9g';
|
||||
my $isComplete = $opts{isComplete};
|
||||
|
||||
# By default, get most recent completed response with any complete code (e.g. isComplete > 0)
|
||||
# This includes abnormal finishes such as timeouts and restarts
|
||||
my $isCompleteClause = defined $isComplete ? "isComplete = $isComplete" : 'isComplete > 0';
|
||||
|
||||
$responseId
|
||||
||= $self->session->db->quickScalar("select Survey_responseId from Survey_response where userId = ? and assetId = ? and isComplete > 0", [ $userId, $self->getId ]);
|
||||
||= $self->session->db->quickScalar("select Survey_responseId from Survey_response where userId = ? and assetId = ? and $isCompleteClause order by endDate desc limit 1", [ $userId, $self->getId ]);
|
||||
|
||||
if (!$responseId) {
|
||||
$self->session->log->debug("ResponseId not found");
|
||||
|
|
@ -1460,15 +1466,17 @@ sub submitQuestions {
|
|||
my $result = $self->recordResponses( $responses );
|
||||
|
||||
# check for special actions
|
||||
if ( my $url = $result->{terminal} ) {
|
||||
$self->session->log->debug('Terminal, surveyEnd');
|
||||
return $self->surveyEnd( { exitUrl => $url } );
|
||||
} elsif ( exists $result->{exitUrl} ) {
|
||||
$self->session->log->debug('exitUrl triggered, surveyEnd');
|
||||
return $self->surveyEnd( { exitUrl => $result->{exitUrl} });
|
||||
} elsif ( my $restart = $result->{restart} ) {
|
||||
$self->session->log->debug('restart triggered');
|
||||
return $self->surveyEnd( { restart => $restart } );
|
||||
if ($result && ref $result eq 'HASH') {
|
||||
if ( my $url = $result->{terminal} ) {
|
||||
$self->session->log->debug('Terminal, surveyEnd');
|
||||
return $self->surveyEnd( { exitUrl => $url } );
|
||||
} elsif ( exists $result->{exitUrl} ) {
|
||||
$self->session->log->debug('exitUrl triggered, surveyEnd');
|
||||
return $self->surveyEnd( { exitUrl => $result->{exitUrl} });
|
||||
} elsif ( my $restart = $result->{restart} ) {
|
||||
$self->session->log->debug('restart triggered');
|
||||
return $self->surveyEnd( { restart => $restart } );
|
||||
}
|
||||
}
|
||||
|
||||
return $self->www_loadQuestions();
|
||||
|
|
@ -1595,21 +1603,21 @@ sub www_loadQuestions {
|
|||
my @questions;
|
||||
eval { @questions = $self->responseJSON->nextQuestions(); };
|
||||
|
||||
# Logical sections cause nextResponse to move when nextQuestions is called, so
|
||||
# persist and changes, and repeat the surveyEnd check in case we are now at the end
|
||||
$self->persistResponseJSON();
|
||||
if ( $self->responseJSON->surveyEnd() ) {
|
||||
$self->session->log->debug('surveyEnd, probably as a result of a Logical Section');
|
||||
if ( $self->get('quizModeSummary') ) {
|
||||
if(! $self->session->form->param('shownsummary')){
|
||||
my ($summary,$html) = $self->getSummary();
|
||||
my $json = to_json( { type => 'summary', summary => $summary, html => $html });
|
||||
$self->session->http->setMimeType('application/json');
|
||||
return $json;
|
||||
}
|
||||
}
|
||||
return $self->surveyEnd();
|
||||
}
|
||||
# # Logical sections cause nextResponse to move when nextQuestions is called, so
|
||||
# # persist and changes, and repeat the surveyEnd check in case we are now at the end
|
||||
# $self->persistResponseJSON();
|
||||
# if ( $self->responseJSON->surveyEnd() ) {
|
||||
# $self->session->log->debug('surveyEnd, probably as a result of a Logical Section');
|
||||
# if ( $self->get('quizModeSummary') ) {
|
||||
# if(! $self->session->form->param('shownsummary')){
|
||||
# my ($summary,$html) = $self->getSummary();
|
||||
# my $json = to_json( { type => 'summary', summary => $summary, html => $html });
|
||||
# $self->session->http->setMimeType('application/json');
|
||||
# return $json;
|
||||
# }
|
||||
# }
|
||||
# return $self->surveyEnd();
|
||||
# }
|
||||
|
||||
my $section = $self->responseJSON->nextResponseSection();
|
||||
|
||||
|
|
@ -1887,79 +1895,49 @@ sub responseId {
|
|||
my $self = shift;
|
||||
my ($userId) = validate_pos(@_, {type => SCALAR, optional => 1});
|
||||
|
||||
$userId ||= $self->session->user->userId;
|
||||
my $user = WebGUI::User->new($self->session, $userId);
|
||||
|
||||
if (!defined $self->{responseId}) {
|
||||
my $ip = $self->session->env->getIp;
|
||||
my $id = $userId || $self->session->user->userId;
|
||||
my $anonId = $self->session->form->process('userid');
|
||||
if ($self->responseIdCookies) {
|
||||
$anonId ||= $self->session->http->getCookies->{Survey2AnonId}; ## no critic
|
||||
}
|
||||
$anonId ||= undef;
|
||||
|
||||
if ($self->responseIdCookies) {
|
||||
$anonId && $self->session->http->setCookie( Survey2AnonId => $anonId );
|
||||
}
|
||||
my $ip = $self->session->env->getIp;
|
||||
|
||||
my ($responseId, $string);
|
||||
|
||||
# if there is an anonid or id is for a WG user
|
||||
if ( $anonId or $id != 1 ) {
|
||||
$string = 'userId';
|
||||
if ($anonId) {
|
||||
$string = 'anonId';
|
||||
$id = $anonId;
|
||||
}
|
||||
$responseId
|
||||
= $self->session->db->quickScalar(
|
||||
"select Survey_responseId from Survey_response where $string = ? and assetId = ? and isComplete = 0",
|
||||
[ $id, $self->getId() ] );
|
||||
my $responseId = $self->{responseId};
|
||||
|
||||
}
|
||||
elsif ( $id == 1 ) {
|
||||
$responseId = $self->session->db->quickScalar(
|
||||
'select Survey_responseId from Survey_response where userId = ? and ipAddress = ? and assetId = ? and isComplete = 0',
|
||||
[ $id, $ip, $self->getId() ]
|
||||
# If a cached responseId doesn't exist, get the current in-progress response from the db
|
||||
$responseId ||= $self->session->db->quickScalar(
|
||||
"select Survey_responseId from Survey_response where userId = ? and assetId = ? and isComplete = 0",
|
||||
[ $userId, $self->getId ] );
|
||||
|
||||
# If no current in-progress response exists, create one (as long as we're allowed to)
|
||||
if ( !$responseId ) {
|
||||
my $maxResponsesPerUser = $self->get('maxResponsesPerUser');
|
||||
my $takenCount = $self->takenCount( { userId => $userId } );
|
||||
if ( $maxResponsesPerUser == 0 || $takenCount < $maxResponsesPerUser ) {
|
||||
# Create a new response
|
||||
$responseId = $self->session->db->setRow(
|
||||
'Survey_response',
|
||||
'Survey_responseId', {
|
||||
Survey_responseId => 'new',
|
||||
userId => $userId,
|
||||
ipAddress => $ip,
|
||||
username => $user->username,
|
||||
startDate => scalar time,
|
||||
endDate => 0,
|
||||
assetId => $self->getId,
|
||||
anonId => undef
|
||||
}
|
||||
);
|
||||
}
|
||||
if ( !$responseId ) {
|
||||
my $maxResponsesPerUser = $self->get('maxResponsesPerUser');
|
||||
my $takenCount;
|
||||
|
||||
if ( $id == 1 ) {
|
||||
$takenCount = $self->takenCount( { userId => $id, ipAddress => $ip } );
|
||||
}
|
||||
else {
|
||||
$takenCount = $self->takenCount( { $string => $id } );
|
||||
}
|
||||
if ( $maxResponsesPerUser == 0 || $takenCount < $maxResponsesPerUser ) {
|
||||
$responseId = $self->session->db->setRow(
|
||||
'Survey_response',
|
||||
'Survey_responseId', {
|
||||
Survey_responseId => 'new',
|
||||
userId => $id,
|
||||
ipAddress => $ip,
|
||||
username => $user ? $user->username : $self->session->user->username,
|
||||
startDate => scalar time, #WebGUI::DateTime->now->toDatabase,
|
||||
endDate => 0, #WebGUI::DateTime->now->toDatabase,
|
||||
assetId => $self->getId(),
|
||||
anonId => $anonId
|
||||
}
|
||||
);
|
||||
|
||||
# Store the newly created responseId
|
||||
$self->{responseId} = $responseId;
|
||||
|
||||
# Manually persist ResponseJSON since we have changed $self->responseId
|
||||
$self->persistResponseJSON();
|
||||
}
|
||||
else {
|
||||
$self->session->log->debug("takenCount ($takenCount) >= maxResponsesPerUser ($maxResponsesPerUser)");
|
||||
}
|
||||
# Store the newly created responseId
|
||||
$self->{responseId} = $responseId;
|
||||
|
||||
# Manually persist ResponseJSON since we have changed $self->responseId
|
||||
$self->persistResponseJSON();
|
||||
}
|
||||
else {
|
||||
$self->session->log->debug("Refusing to create new response, takenCount ($takenCount) >= maxResponsesPerUser ($maxResponsesPerUser)");
|
||||
}
|
||||
$self->{responseId} = $responseId;
|
||||
}
|
||||
$self->{responseId} = $responseId;
|
||||
|
||||
return $self->{responseId};
|
||||
}
|
||||
|
||||
|
|
@ -1974,16 +1952,18 @@ and thus should not count towards tally)
|
|||
|
||||
sub takenCount {
|
||||
my $self = shift;
|
||||
my %opts = validate(@_, { userId => 0, anonId => 0, ipAddress => 0 });
|
||||
my %opts = validate(@_, { userId => 0, anonId => 0, ipAddress => 0, isComplete => 0 });
|
||||
my $isComplete = defined $opts{isComplete} ? $opts{isComplete} : 1;
|
||||
|
||||
my $sql = 'select count(*) from Survey_response where';
|
||||
$sql .= ' assetId = ' . $self->session->db->quote($self->getId);
|
||||
$sql .= ' and isComplete = 1';
|
||||
$sql .= ' and isComplete = ' . $self->session->db->quote($isComplete);
|
||||
for my $o qw(userId anonId ipAddress) {
|
||||
if (my $o_value = $opts{o}) {
|
||||
$sql .= " and $o = " . $self->session->db->quote($o_value);
|
||||
}
|
||||
}
|
||||
$self->session->log->debug($sql);
|
||||
|
||||
my $count = $self->session->db->quickScalar($sql);
|
||||
return $count;
|
||||
|
|
@ -2217,6 +2197,81 @@ sub www_exportTransposedResults {
|
|||
return $self->export( $filename, $content );
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
sub www_exportStructure {
|
||||
my $self = shift;
|
||||
|
||||
return $self->session->privilege->insufficient()
|
||||
unless ( $self->session->user->isInGroup( $self->get('groupToEditSurvey') ) );
|
||||
|
||||
if ($self->session->form->param('format') eq 'html') {
|
||||
my $output = <<END_HTML;
|
||||
<p>N.B. Items are formatted as:
|
||||
<ul>
|
||||
<li>Section Number: (<b>variable</b>) “Section Title”</li>
|
||||
<li>Question Number: (<b>variable</b>) “Question Title”</li>
|
||||
<ul><li>Answer Number: (<b>Recorded Answer,Answer Score</b>) “Answer Text”</li></ul>
|
||||
</ul>
|
||||
</p>
|
||||
<div style="border: 1px dashed; margin: 10px; padding: 10px;">
|
||||
END_HTML
|
||||
my $sNum = 1;
|
||||
for my $s (@{$self->surveyJSON->sections}) {
|
||||
$output .= "S$sNum: (<b>$s->{variable}</b>) “$s->{title}”";
|
||||
$output .= '<ul>';
|
||||
my $qNum = 0;
|
||||
for my $q (@{$s->{questions}}) {
|
||||
$qNum++;
|
||||
$output .= '<li>';
|
||||
$output .= "Q$qNum: (<b>$q->{variable}</b>) “$q->{text}”";
|
||||
$output .= '<ul>';
|
||||
my $aNum = 0;
|
||||
for my $a (@{$q->{answers}}) {
|
||||
$aNum++;
|
||||
$output .= '<li>';
|
||||
$output .= "A$aNum: (<b>$a->{recordedAnswer},$a->{value}</b>) “$a->{text}”";
|
||||
$output .= '</li>';
|
||||
}
|
||||
$output .= '</ul>';
|
||||
$output .= '</li>';
|
||||
}
|
||||
$output .= '</ul>';
|
||||
}
|
||||
$output .= '</div>';
|
||||
|
||||
return $self->session->style->userStyle($output);
|
||||
} else {
|
||||
my @rows = ([qw( numbering type variable recordedValue score text goto gotoExpression)]);
|
||||
my $sNum = 0;
|
||||
for my $s (@{$self->surveyJSON->sections}) {
|
||||
$sNum++;
|
||||
push @rows, ["S$sNum", 'Section', $s->{variable}, '', '', $s->{text}, $s->{goto}, $s->{gotoExpression}];
|
||||
my $qNum = 0;
|
||||
for my $q (@{$s->{questions}}) {
|
||||
$qNum++;
|
||||
push @rows, ["S$sNum-Q$qNum", 'Question', $q->{variable}, '', '', $q->{text}, $q->{goto}, $q->{gotoExpression}];
|
||||
my $aNum = 0;
|
||||
for my $a (@{$q->{answers}}) {
|
||||
$aNum++;
|
||||
push @rows, ["S$sNum-Q$qNum-A$aNum", 'Answer', '', $a->{recordedAnswer}, $a->{value}, $a->{text}, $a->{goto}, $a->{gotoExpression}];
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
use Text::CSV_XS;
|
||||
my $csv = Text::CSV_XS->new( { binary => 1 } );
|
||||
my @lines = map {$csv->combine(@$_); $csv->string} @rows;
|
||||
my $output = join "\n", @lines;
|
||||
|
||||
my $filename = $self->session->url->escape( $self->get("title") . "_structure.csv" );
|
||||
$self->session->http->setFilename($filename,"text/csv");
|
||||
|
||||
return $output;
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 export($filename,$content)
|
||||
|
|
@ -2450,14 +2505,14 @@ sub www_editTestSuite {
|
|||
my $icon = $session->icon;
|
||||
while (my $test = $getATest->()) {
|
||||
$testsFound++;
|
||||
my $id = $test->getId;
|
||||
my $testId = $test->getId;
|
||||
my $name = $test->get('name');
|
||||
$tests .= '<tr><td>'
|
||||
. $icon->delete( 'func=deleteTest;testId='.$id, undef, $i18n->get('confirm delete test'))
|
||||
. $icon->edit( 'func=editTest;testId='.$id)
|
||||
. $icon->moveDown('func=demoteTest;testId='.$id)
|
||||
. $icon->moveUp( 'func=promoteTest;testId='.$id)
|
||||
. qq{<a href="} . $session->url->page("func=runTest;testId=$id") . qq{">Run Test</a>}
|
||||
. $icon->delete( 'func=deleteTest;testId='.$testId, undef, $i18n->get('confirm delete test'))
|
||||
. $icon->edit( 'func=editTest;testId='.$testId)
|
||||
. $icon->moveDown('func=demoteTest;testId='.$testId)
|
||||
. $icon->moveUp( 'func=promoteTest;testId='.$testId)
|
||||
. qq{<a href="} . $session->url->page("func=runTest;testId=$testId") . qq{">Run Test</a>}
|
||||
. '</td><td>'.$name.'</td></tr>';
|
||||
}
|
||||
$tests .= '</tbody></table><div style="clear: both;"></div>';
|
||||
|
|
@ -2508,13 +2563,14 @@ sub www_editTest {
|
|||
$form->hidden( name=>"assetId", value=>$self->getId);
|
||||
$form->dynamicForm([WebGUI::Asset::Wobject::Survey::Test->crud_definition($session)], 'properties', $test);
|
||||
$form->submit;
|
||||
|
||||
my $i18n = WebGUI::International->new($session, 'Asset_Survey');
|
||||
my $ac = $self->getAdminConsole;
|
||||
|
||||
if ($testId eq 'new') {
|
||||
$test->delete;
|
||||
}
|
||||
my $ac = $self->getAdminConsole;
|
||||
my $i18n = WebGUI::International->new($session, 'Asset_Survey');
|
||||
$ac->addSubmenuItem($self->session->url->page("func=editTest;testId=$testId"), $i18n->get('edit test'));
|
||||
$ac->addSubmenuItem($self->session->url->page("func=runTest;testId=$testId"), $i18n->get('run test'));
|
||||
return $ac->render($error.$form->print, $i18n->get('edit test'));
|
||||
}
|
||||
|
||||
|
|
@ -2600,9 +2656,9 @@ sub www_runTest {
|
|||
return $self->session->privilege->insufficient()
|
||||
unless $self->session->user->isInGroup( $self->get('groupToEditSurvey') );
|
||||
|
||||
my $id = $session->form->get("testId");
|
||||
my $testId = $session->form->get("testId");
|
||||
|
||||
my $test = WebGUI::Asset::Wobject::Survey::Test->new($session, $id)
|
||||
my $test = WebGUI::Asset::Wobject::Survey::Test->new($session, $testId)
|
||||
or return $self->www_editTestSuite('Unable to find test');
|
||||
|
||||
my $result = $test->run or return $self->www_editTestSuite('Unable to run test');
|
||||
|
|
@ -2611,10 +2667,10 @@ sub www_runTest {
|
|||
|
||||
my $parsed = $self->parseTap($tap) or return $self->www_editTestSuite('Unable to parse test output');
|
||||
|
||||
my $ac = $self->getAdminConsole;
|
||||
my $edit = WebGUI::International->new($self->session, "WebGUI")->get(575);
|
||||
$ac->addSubmenuItem($self->session->url->page("func=editTest;testId=$id"), "$edit Test");
|
||||
$ac->addSubmenuItem($self->session->url->page("func=runTests"), "Run All Tests");
|
||||
my $ac = $self->getAdminConsole;
|
||||
my $i18n = WebGUI::International->new($session, 'Asset_Survey');
|
||||
$ac->addSubmenuItem($self->session->url->page("func=editTest;testId=$testId"), $i18n->get('edit test'));
|
||||
$ac->addSubmenuItem($self->session->url->page("func=runTest;testId=$testId"), $i18n->get('run test'));
|
||||
return $ac->render($parsed->{templateText}, 'Test Results');
|
||||
}
|
||||
|
||||
|
|
@ -2693,6 +2749,7 @@ Runs all tests
|
|||
|
||||
sub www_runTests {
|
||||
my $self = shift;
|
||||
|
||||
my $session = $self->session;
|
||||
my $i18n = WebGUI::International->new($self->session, "Asset_Survey");
|
||||
return $self->session->privilege->insufficient()
|
||||
|
|
@ -2705,6 +2762,8 @@ sub www_runTests {
|
|||
aggregate => 1,
|
||||
results => [],
|
||||
};
|
||||
my $format = $self->session->form->param('format');
|
||||
local $| = 1 if $format eq 'tap';
|
||||
|
||||
my @parsers;
|
||||
use TAP::Parser::Aggregator;
|
||||
|
|
@ -2723,6 +2782,7 @@ sub www_runTests {
|
|||
testId => $test->getId,
|
||||
text => $parsed->{templateText},
|
||||
};
|
||||
$self->session->output->print("$name\n$tap\n\n") if $format eq 'tap';
|
||||
}
|
||||
$aggregate->stop;
|
||||
|
||||
|
|
@ -2750,7 +2810,18 @@ sub www_runTests {
|
|||
my $out = $self->processTemplate($var, $self->get('testResultsTemplateId') || 'S3zpVitAmhy58CAioH359Q');
|
||||
|
||||
my $ac = $self->getAdminConsole;
|
||||
return $ac->render($out, $i18n->get('test results'));
|
||||
if ($format eq 'tap') {
|
||||
my $summary = <<'END_SUMMARY';
|
||||
SUMMARY
|
||||
-------
|
||||
Passed: %s
|
||||
Failed: %s
|
||||
END_SUMMARY
|
||||
$self->session->output->print(sprintf $summary, scalar $aggregate->passed, scalar $aggregate->failed);
|
||||
return 'chunked';
|
||||
} else {
|
||||
return $ac->render($out, $i18n->get('test results'));
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -106,6 +106,9 @@ sub reset {
|
|||
# And then data overrides
|
||||
%{$data},
|
||||
};
|
||||
|
||||
# If first section is logical, process it immediately
|
||||
$self->checkForLogicalSection;
|
||||
return $self;
|
||||
}
|
||||
|
||||
|
|
@ -214,6 +217,9 @@ Mutator. The lastResponse property represents the surveyOrder index of the most
|
|||
|
||||
This method returns (and optionally sets) the value of lastResponse.
|
||||
|
||||
You may want to call L<checkForLogicalSection> after modifying this so that
|
||||
any logical section you land in gets immediately processed.
|
||||
|
||||
=head3 $responseIndex (optional)
|
||||
|
||||
If defined, lastResponse is set to $responseIndex.
|
||||
|
|
@ -397,6 +403,9 @@ Mutator. The index of the next item that should be shown to the user,
|
|||
that is, the index of the next item in the L<"surveyOrder"> array,
|
||||
e.g. L<"lastResponse"> + 1.
|
||||
|
||||
You may want to call L<checkForLogicalSection> after modifying this so that
|
||||
any logical section you land in gets immediately processed.
|
||||
|
||||
=head3 $responseIndex (optional)
|
||||
|
||||
If defined, nextResponse is set to $responseIndex.
|
||||
|
|
@ -480,7 +489,7 @@ Processes and records submitted survey responses in the L<"responses"> data stru
|
|||
Does terminal handling, and branch processing, and advances the L<"lastResponse"> index
|
||||
if all required questions have been answered.
|
||||
|
||||
=head3 $submittedResponses
|
||||
=head3 $responses
|
||||
|
||||
A hash ref of submitted form param data. Each element should look like:
|
||||
|
||||
|
|
@ -492,219 +501,226 @@ A hash ref of submitted form param data. Each element should look like:
|
|||
|
||||
See L<"questionId"> and L<"answerId">.
|
||||
|
||||
=head3 Terminal processing
|
||||
=head3 Terminal, goto and gotoExpression processing
|
||||
|
||||
Terminal processing for a section and its questions and answers are handled in
|
||||
order. The terminalUrl setting in a question overrides the terminalUrl setting
|
||||
for its section. Similarly, with questions and answers, the last terminalUrl
|
||||
setting of the set of questions is what is returned for the page, with the questions
|
||||
and answers being answered in L<"surveyOrder">.
|
||||
Gotos are processed first, followed by gotoExpressions, and finally terminals.
|
||||
On a page with the following items:
|
||||
Section 1
|
||||
Question 1.1
|
||||
Answer 1.1.1
|
||||
Answer 1.1.2
|
||||
Question 1.2
|
||||
Answer 1.2.1
|
||||
..
|
||||
|
||||
=head3 Branch processing
|
||||
the precedence order is inside-out, in order of questions displayed, e.g.
|
||||
|
||||
Jump targets (gotos) and jump expressions (gotoExpressions) are attempted in the following
|
||||
order:
|
||||
Answer 1.1.1
|
||||
Answer 1.1.2
|
||||
Question 1.1
|
||||
Answer 1.2.1
|
||||
Question 1.2
|
||||
Section 1
|
||||
|
||||
=over 3
|
||||
|
||||
=item * answer goto
|
||||
|
||||
=item * answer gotoExpression
|
||||
|
||||
=item * question goto
|
||||
|
||||
=item * question gotoExpression
|
||||
|
||||
=item * question goto
|
||||
|
||||
=item * question gotoExpression
|
||||
|
||||
=back
|
||||
|
||||
The first to trigger a jump short-circuits the process, and subsequent items are not attempted.
|
||||
The first to trigger a jump short-circuits the process, meaning that subsequent items are not attempted.
|
||||
|
||||
=cut
|
||||
|
||||
sub recordResponses {
|
||||
my $self = shift;
|
||||
my ($submittedResponses) = validate_pos( @_, { type => HASHREF } );
|
||||
my ($responses) = validate_pos( @_, { type => HASHREF } );
|
||||
|
||||
# Build a lookup table of non-multiple choice question types
|
||||
my %knownTypes = map {$_ => 1} @{$self->survey->specialQuestionTypes};
|
||||
|
||||
my %specialQTypes = map { $_ => 1 } @{ $self->survey->specialQuestionTypes };
|
||||
|
||||
# We want to record responses against the "next" response section and questions, since these are
|
||||
# the items that have just been displayed to the user.
|
||||
my $section = $self->nextResponseSection();
|
||||
my $section = $self->nextResponseSection();
|
||||
|
||||
my ($sectionGoto, $questionGoto, $answerGoto, $sectionExpression, $questionExpression, $answerExpression);
|
||||
# Process responses by looping over expected questions in survey order
|
||||
my @questions = $self->nextQuestions();
|
||||
my %newResponse;
|
||||
my $allQsValid = 1;
|
||||
my %validAnswers;
|
||||
for my $question (@questions) {
|
||||
my $aValid = 0; # TODO: this is flawed because we can have multi-answer quesions
|
||||
my $qId = $question->{id};
|
||||
|
||||
# Handle terminal Section..
|
||||
my $terminalUrl;
|
||||
my $sTerminal = 0;
|
||||
if ( $section->{terminal} ) {
|
||||
$sTerminal = 1;
|
||||
$terminalUrl = $section->{terminalUrl};
|
||||
}
|
||||
# ..and also gotos..
|
||||
elsif ( $section->{goto} =~ /\w/ ) {
|
||||
$sectionGoto = $section->{goto};
|
||||
}
|
||||
# .. and also gotoExpressions..
|
||||
elsif ( $section->{gotoExpression} =~ /\w/ ) {
|
||||
$sectionExpression = $section->{gotoExpression};
|
||||
$newResponse{ $qId }->{comment} = $responses->{ "${qId}comment" };
|
||||
|
||||
for my $answer ( @{ $question->{answers} } ) {
|
||||
my $aId = $answer->{id};
|
||||
my $recordedAnswer = $responses->{ $aId };
|
||||
my $questionType = $question->{questionType};
|
||||
|
||||
# Server-side Validation and storing of extra data for special q types goes here
|
||||
# Any answer that fails validation should be skipped with 'next'
|
||||
|
||||
|
||||
if ( $questionType eq 'Number' ) {
|
||||
if ( $answer->{max} =~ /\d/ and $recordedAnswer > $answer->{max} ) {
|
||||
next;
|
||||
}
|
||||
elsif ( $answer->{min} =~ /\d/ and $recordedAnswer < $answer->{min} ) {
|
||||
next;
|
||||
}
|
||||
elsif ( $answer->{step} =~ /\d/ and $recordedAnswer % $answer->{step} != 0 ) {
|
||||
next;
|
||||
}
|
||||
}
|
||||
elsif ( $questionType eq 'Year Month' ) {
|
||||
# store year and month as "YYYY Month"
|
||||
$recordedAnswer = $responses->{ "$aId-year" } . " " . $responses->{ "$aId-month" };
|
||||
}
|
||||
else {
|
||||
# In the case of a mc question, only selected answers will have a defined recordedAnswer
|
||||
# Thus we skip any answers where recordedAnswer is not defined
|
||||
next if !defined $recordedAnswer || $recordedAnswer !~ /\S/;
|
||||
}
|
||||
|
||||
# If we reach here, answer validated ok
|
||||
$aValid = 1;
|
||||
$validAnswers{$aId} = 1;
|
||||
|
||||
# Now, decide what to record. For multi-choice questions, use recordedAnswer.
|
||||
# Otherwise, we use the (raw) submitted response (e.g. text input, date input etc..)
|
||||
$newResponse{ $aId } = {
|
||||
value => $specialQTypes{ $questionType } ? $recordedAnswer : $answer->{recordedAnswer},
|
||||
verbatim => $answer->{verbatim} ? $responses->{ "${aId}verbatim" } : undef,
|
||||
time => time,
|
||||
comment => $responses->{ "${aId}comment" },
|
||||
};
|
||||
}
|
||||
|
||||
# Check if a required Question was skipped
|
||||
$allQsValid = 0 if $question->{required} && !$aValid;
|
||||
|
||||
# If question was answered, increment the questionsAnswered count..
|
||||
$self->questionsAnswered(+1) if $aValid;
|
||||
}
|
||||
|
||||
my $logicalSection = $section->{logical};
|
||||
|
||||
# Process Questions in Section..
|
||||
my $terminal = 0;
|
||||
my $allRequiredQsAnswered = 1;
|
||||
my @questions;
|
||||
# Stop here on validation errors
|
||||
if ( !$allQsValid ) {
|
||||
$self->session->log->debug("One or more questions failed validation");
|
||||
return;
|
||||
}
|
||||
|
||||
if (!$logicalSection) {
|
||||
# Add newResponse to the overall response (via a hash slice)
|
||||
@{$self->responses}{keys %newResponse} = values %newResponse;
|
||||
|
||||
# Now that the response has been recorded, increment nextResponse
|
||||
# N.B. This can be overwritten by goto and gotoExpressions, below.
|
||||
# (we give them a chance to run before processing logical sections)
|
||||
# Normally we move forward by the number of questions answered, but if
|
||||
# the section has no questions we still move forward by 1
|
||||
$self->nextResponse( $self->nextResponse + ( @questions || 1 ) );
|
||||
|
||||
# Now that the response has been added, loop over the questions a second time
|
||||
# to process goto, gotoExpression, and terminalUrls.
|
||||
#
|
||||
# We are only dealing with a single section. On a page with:
|
||||
#
|
||||
# Section 1
|
||||
# Question 1.1
|
||||
# Answer 1.1.1
|
||||
# Answer 1.1.2
|
||||
# Question 1.2
|
||||
# Answer 1.2.1
|
||||
# ..
|
||||
#
|
||||
# the precedence order is inside-out, in order of questions displayed, e.g.
|
||||
#
|
||||
# Answer 1.1.1
|
||||
# Answer 1.1.2
|
||||
# Question 1.1
|
||||
# Answer 1.2.1
|
||||
# Question 1.2
|
||||
# Section 1
|
||||
# ..
|
||||
for my $question (@questions) {
|
||||
|
||||
# N.B. Important that nextQuestions is not called for logicalSetions, since
|
||||
# logical sections cause this sub to be called from nextQuestions() in the first place!
|
||||
@questions = $self->nextQuestions();
|
||||
# First Answers..
|
||||
|
||||
for my $question (@questions) {
|
||||
my $aAnswered = 0;
|
||||
|
||||
# Handle terminal Questions..
|
||||
if ( $question->{terminal} ) {
|
||||
$terminal = 1;
|
||||
$terminalUrl = $question->{terminalUrl};
|
||||
for my $answer ( @{ $question->{answers} } ) {
|
||||
# Only process the chosen answer..
|
||||
my $aId = $answer->{id};
|
||||
next if !$validAnswers{$aId};
|
||||
|
||||
# Answer goto
|
||||
if (my $action = $self->processGoto($answer->{goto})) {
|
||||
$self->session->log->debug("Branching on Answer goto: $answer->{goto}");
|
||||
return $action;
|
||||
}
|
||||
# ..and also gotos..
|
||||
elsif ( $question->{goto} =~ /\w/ ) {
|
||||
$questionGoto = $question->{goto};
|
||||
# Then answer gotoExpression
|
||||
if (my $action = $self->processExpression($answer->{gotoExpression})) {
|
||||
$self->session->log->debug("Branching on Answer gotoExpression: $answer->{gotoExpression}");
|
||||
return $action;
|
||||
}
|
||||
# .. and also gotoExpressions..
|
||||
elsif ( $question->{gotoExpression} =~ /\w/ ) {
|
||||
$questionExpression = $question->{gotoExpression};
|
||||
}
|
||||
|
||||
# Record Question comment
|
||||
$self->responses->{ $question->{id} }->{comment} = $submittedResponses->{ $question->{id} . 'comment' };
|
||||
|
||||
# Process Answers in Question..
|
||||
for my $answer ( @{ $question->{answers} } ) {
|
||||
|
||||
# Pluck the values out of the responses hash that we want to record..
|
||||
my $submittedAnswerResponse = $submittedResponses->{ $answer->{id} };
|
||||
my $submittedAnswerComment = $submittedResponses->{ $answer->{id} . 'comment' };
|
||||
my $submittedAnswerVerbatim = $submittedResponses->{ $answer->{id} . 'verbatim' };
|
||||
|
||||
# Server-side Validation and storing of extra data for special q types goes here
|
||||
|
||||
if($question->{questionType} eq 'Number'){
|
||||
if($answer->{max} =~ /\d/ and $submittedAnswerResponse > $answer->{max}){
|
||||
next;
|
||||
}elsif($answer->{min} =~ /\d/ and $submittedAnswerResponse < $answer->{min}){
|
||||
next;
|
||||
}elsif($answer->{step} =~ /\d/ and $submittedAnswerResponse % $answer->{step} != 0){
|
||||
next;
|
||||
}
|
||||
} elsif ($question->{questionType} eq 'Year Month'){
|
||||
# store year and month as "YYYY Month"
|
||||
$submittedAnswerResponse = $submittedResponses->{ $answer->{id} . '-year' } . " " . $submittedResponses->{ $answer->{id} . '-month' };
|
||||
} else {
|
||||
if ( !defined $submittedAnswerResponse || $submittedAnswerResponse !~ /\S/ ) {
|
||||
$self->session->log->debug("Skipping invalid submitted answer response: $submittedAnswerResponse") if $submittedAnswerResponse;
|
||||
next;
|
||||
}
|
||||
}
|
||||
|
||||
# If we reach here, answer validated ok
|
||||
$aAnswered = 1;
|
||||
|
||||
# Now, decide what to record. For multi-choice questions, use recordedAnswer.
|
||||
# Otherwise, we use the (raw) submitted response (e.g. text input, date input etc..)
|
||||
$self->responses->{ $answer->{id} }->{value}
|
||||
= $knownTypes{ $question->{questionType} }
|
||||
? $submittedAnswerResponse
|
||||
: $answer->{recordedAnswer};
|
||||
|
||||
$self->responses->{ $answer->{id} }->{verbatim} = $answer->{verbatim} ? $submittedAnswerVerbatim : undef;
|
||||
$self->responses->{ $answer->{id} }->{time} = time;
|
||||
$self->responses->{ $answer->{id} }->{comment} = $submittedAnswerComment;
|
||||
|
||||
# Handle terminal Answers..
|
||||
if ( $answer->{terminal} ) {
|
||||
$terminal = 1;
|
||||
$terminalUrl = $answer->{terminalUrl};
|
||||
}
|
||||
|
||||
# ..and also gotos..
|
||||
elsif ( $answer->{goto} =~ /\w/ ) {
|
||||
$answerGoto = $answer->{goto};
|
||||
}
|
||||
|
||||
# .. and also gotoExpressions..
|
||||
elsif ( $answer->{gotoExpression} =~ /\w/ ) {
|
||||
$answerExpression = $answer->{gotoExpression};
|
||||
}
|
||||
}
|
||||
|
||||
# Check if a required Question was skipped
|
||||
if ( $question->{required} && !$aAnswered ) {
|
||||
$allRequiredQsAnswered = 0;
|
||||
}
|
||||
|
||||
# If question was answered, increment the questionsAnswered count..
|
||||
if ($aAnswered) {
|
||||
$self->questionsAnswered(+1);
|
||||
# Then answer terminal
|
||||
if ($answer->{terminal}) {
|
||||
$self->session->log->debug("Answer terminal: $answer->{terminalUrl}");
|
||||
return { terminal => $answer->{terminalUrl} };
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# If all required responses were given, proceed onwards!
|
||||
if ($allRequiredQsAnswered && !$logicalSection) {
|
||||
|
||||
# Move the lastResponse index to the last question answered
|
||||
$self->lastResponse( $self->lastResponse + @questions );
|
||||
}
|
||||
|
||||
if ($allRequiredQsAnswered || $logicalSection) {
|
||||
# Process jumps and jump expressions in precedence order of:
|
||||
# answer goto, answer expression, question goto, question expression, section..
|
||||
# Then Questions..
|
||||
|
||||
# The joined logical OR here carries out the short-circuting for us
|
||||
# e.g. processGoto returns 1 on its first match
|
||||
# and processExpression returns hashref on its first match
|
||||
my $action = $self->processGoto($answerGoto) ||
|
||||
$self->processExpression($answerExpression) ||
|
||||
$self->processGoto($questionGoto) ||
|
||||
$self->processExpression($questionExpression) ||
|
||||
$self->processGoto($sectionGoto) ||
|
||||
$self->processExpression($sectionExpression);
|
||||
|
||||
# Special actions (such as exitUrl and restart) happen straight away
|
||||
if ($action && ref $action eq 'HASH') {
|
||||
# Question goto
|
||||
if (my $action = $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})) {
|
||||
$self->session->log->debug("Branching on Question gotoExpression: $question->{gotoExpression}");
|
||||
return $action;
|
||||
}
|
||||
# N.B. Questions don't have terminalUrls
|
||||
}
|
||||
|
||||
if (!$allRequiredQsAnswered) {
|
||||
# Required responses were missing, so we don't let the Survey terminate
|
||||
$terminal = 0;
|
||||
# Then Sections..
|
||||
|
||||
# Section goto
|
||||
if (my $action = $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})) {
|
||||
$self->session->log->debug("Branching on Section gotoExpression: $section->{gotoExpression}");
|
||||
return $action;
|
||||
}
|
||||
# Then section terminal
|
||||
if ($section->{terminal} && $self->nextResponseSectionIndex != $self->lastResponseSectionIndex) {
|
||||
$self->session->log->debug("Section terminal: $section->{terminalUrl}");
|
||||
return { terminal => $section->{terminalUrl} };
|
||||
}
|
||||
|
||||
# The above goto and gotoExpression checks will have already called $self->checkForLogicalSection after
|
||||
# moving nextResponse, however we need to call it again here for the case where the survey fell
|
||||
# through naturally to a logical section
|
||||
$self->checkForLogicalSection;
|
||||
|
||||
$self->session->log->debug("Falling through..");
|
||||
return;
|
||||
}
|
||||
|
||||
# Handle special cases down here, after we've given sections a chance for their jump [expressions] to run
|
||||
if ( !@questions || $logicalSection ) {
|
||||
# No questions to be (or should be) displayed, so increment lastResponse and return
|
||||
$self->lastResponse( $self->nextResponse );
|
||||
return $sTerminal ? { terminal => $terminalUrl } : {};
|
||||
}
|
||||
=head2 checkForLogicalSection
|
||||
|
||||
if ( $sTerminal && $self->nextResponseSectionIndex != $self->lastResponseSectionIndex ) {
|
||||
$terminal = 1;
|
||||
}
|
||||
Check if the next response section is marked as logical, and if so, immediately processed it.
|
||||
Normally, this sub should be called every time lastResponse or nextResponse is modified, so
|
||||
that logical sections "automatically" trigger.
|
||||
|
||||
if ($terminal) {
|
||||
return { terminal => $terminalUrl };
|
||||
=cut
|
||||
|
||||
sub checkForLogicalSection {
|
||||
my $self = shift;
|
||||
my $section = $self->nextResponseSection();
|
||||
if ($section && $section->{logical}) {
|
||||
$self->session->log->debug("Processing logical section $section->{variable}");
|
||||
$self->recordResponses({});
|
||||
}
|
||||
return {};
|
||||
return;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
@ -735,12 +751,14 @@ sub processGoto {
|
|||
while ($self->nextResponseSectionIndex == $lastResponseSectionIndex) {
|
||||
$self->lastResponse( $self->lastResponse + 1);
|
||||
}
|
||||
$self->checkForLogicalSection;
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($goto eq 'END_SURVEY') {
|
||||
$self->session->log->debug("END_SURVEY jump target encountered");
|
||||
$self->lastResponse( scalar( @{ $self->surveyOrder} ) - 1 );
|
||||
$self->checkForLogicalSection;
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
|
@ -757,6 +775,7 @@ sub processGoto {
|
|||
|
||||
# Fudge lastResponse so that the next response item will be our matching item
|
||||
$self->lastResponse( $itemIndex - 1 );
|
||||
$self->checkForLogicalSection;
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
|
@ -765,6 +784,7 @@ sub processGoto {
|
|||
|
||||
# Fudge lastResponse so that the next response item will be our matching item
|
||||
$self->lastResponse( $itemIndex - 1 );
|
||||
$self->checkForLogicalSection;
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
|
@ -1038,7 +1058,8 @@ A hash reference. Each matching key in the string will be replaced with its asso
|
|||
|
||||
sub getTemplatedText {
|
||||
my $self = shift;
|
||||
my ($text, $params) = validate_pos(@_, { type => SCALAR }, { type => HASHREF });
|
||||
my ($text, $params) = validate_pos(@_, { type => SCALAR|UNDEF }, { type => HASHREF });
|
||||
$text = q{} if not defined $text;
|
||||
|
||||
# Turn multi-valued answers into comma-separated text
|
||||
for my $value (values %$params) {
|
||||
|
|
@ -1089,26 +1110,6 @@ sub nextQuestions {
|
|||
|
||||
# Get some information about the Section that the next response belongs to..
|
||||
my $section = $self->nextResponseSection();
|
||||
|
||||
# Logical sections get processed immediately rather than displayed
|
||||
if ($section->{logical}) {
|
||||
my $nextResponse = $self->nextResponse;
|
||||
|
||||
$self->session->log->debug("Processing logical section");
|
||||
|
||||
# Pass off to recordResponses, which will process expressions and increment nextResponse
|
||||
$self->recordResponses({});
|
||||
|
||||
# Explicitly check that nextResponse was incremented, lest we end up with an infinite loop
|
||||
if ($nextResponse == $self->nextResponse) {
|
||||
$self->session->log->error("Something bad happened in Survey logic, bailing out to avoid infinite loop");
|
||||
} else {
|
||||
$self->session->log->debug("nextResponse has been updated to " . $self->nextResponse);
|
||||
# ..and then start over
|
||||
return $self->nextQuestions;
|
||||
}
|
||||
}
|
||||
|
||||
my $sectionIndex = $self->nextResponseSectionIndex;
|
||||
my $questionsPerPage = $self->survey->section( [ $self->nextResponseSectionIndex ] )->{questionsPerPage};
|
||||
|
||||
|
|
|
|||
|
|
@ -960,11 +960,6 @@ 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.
|
||||
|
|
@ -986,6 +981,7 @@ sub updateQuestionAnswers {
|
|||
# Get the indexed question, and remove all of its existing answers
|
||||
my $question = $self->question($address);
|
||||
$question->{answers} = [];
|
||||
$question->{questionType} = $type;
|
||||
|
||||
# Add the default set of answers. The question type determines both the number
|
||||
# of answers added and the answer text to use. When updating answer text
|
||||
|
|
|
|||
|
|
@ -281,8 +281,10 @@ sub _test {
|
|||
|
||||
while ( my ( $variable, $spec ) = each %$args ) {
|
||||
my $index = $surveyOrderIndexByVariableName->{$variable};
|
||||
return fail($testCount, "Invalid question variable: $variable") if !defined $index;
|
||||
my $address = $surveyOrder->[$index];
|
||||
my $question = $rJSON->survey->question($address);
|
||||
return fail($testCount, "Invalid question variable: $variable") if !defined $question;
|
||||
my $questionType = $question->{questionType};
|
||||
|
||||
# Keep track of lowest index (to work out what survey page we should test on)
|
||||
|
|
@ -325,6 +327,7 @@ sub _test {
|
|||
|
||||
my ($pageSection, $pageQuestion);
|
||||
if (defined $lowestIndex) {
|
||||
my $address = $surveyOrder->[$lowestIndex] or return fail($testCount, "Unable to determine address from lowest index: $lowestIndex");
|
||||
$rJSON->nextResponse($lowestIndex);
|
||||
$pageSection = $rJSON->survey->section($surveyOrder->[$lowestIndex]);
|
||||
$pageQuestion = $rJSON->survey->question($surveyOrder->[$lowestIndex]);
|
||||
|
|
@ -427,8 +430,10 @@ sub _test_mc {
|
|||
my @specs = @$args;
|
||||
|
||||
my $index = $surveyOrderIndexByVariableName->{$variable};
|
||||
return fail(-1, "Invalid question variable: $variable") if !defined $index;
|
||||
my $address = $surveyOrder->[$index];
|
||||
my $question = $rJSON->survey->question($address);
|
||||
return fail(-1, "Invalid question variable: $variable") if !defined $question;
|
||||
my $answers = $question->{answers};
|
||||
|
||||
# Each spec is a sub-test, one per answer in the question
|
||||
|
|
@ -517,8 +522,10 @@ sub _sequence {
|
|||
|
||||
while ( my ( $variable, $spec ) = each %$args ) {
|
||||
my $index = $surveyOrderIndexByVariableName->{$variable};
|
||||
return fail($testCount, "Invalid question variable: $variable") if !defined $index;
|
||||
my $address = $surveyOrder->[$index];
|
||||
my $question = $rJSON->survey->question($address);
|
||||
return fail($testCount, "Invalid question variable: $variable") if !defined $question;
|
||||
my $questionType = $question->{questionType};
|
||||
|
||||
# Iterate over all answers
|
||||
|
|
@ -648,27 +655,38 @@ sub _recordResponses {
|
|||
if ($next) {
|
||||
my $nextResponse = $rJSON->nextResponse;
|
||||
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 .= " and '$qvar' (<-- a question)" if $qvar;
|
||||
} elsif ($qvar) {
|
||||
$got = "'$qvar' (<-- a question)";
|
||||
} else {
|
||||
$got = 'Unknown!';
|
||||
}
|
||||
my $expectedNextResponse = $surveyOrderIndexByVariableName->{$next};
|
||||
if ($nextResponse != $expectedNextResponse) {
|
||||
if ($next ne 'SURVEY_END' && !defined $nextAddress) {
|
||||
return fail($testCount, $name, <<END_WHY);
|
||||
Compared next section/question
|
||||
got : Survey finished
|
||||
expect : '$next'
|
||||
END_WHY
|
||||
}
|
||||
if ($next eq 'SURVEY_END' && !defined $nextAddress) {
|
||||
$self->session->log->debug("SURVEY_END matched correctly");
|
||||
} else {
|
||||
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 .= " and '$qvar' (<-- a question)" if $qvar;
|
||||
} elsif ($qvar) {
|
||||
$got = "'$qvar' (<-- a question)";
|
||||
} else {
|
||||
$got = 'Unknown!';
|
||||
}
|
||||
my $expectedNextResponse = $surveyOrderIndexByVariableName->{$next};
|
||||
if ($nextResponse != $expectedNextResponse) {
|
||||
return fail($testCount, $name, <<END_WHY);
|
||||
Compared next section/question
|
||||
got : $got
|
||||
expect : '$next'
|
||||
END_WHY
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue