Survey test suite now functional.
Tests are defined via a JSON-encoded spec, through Web Crud interface Test results are TAP encoded, and TAP parsed and prettified into HTML Added i18n, help and tests
This commit is contained in:
Patrick Donelan
parent
fd5f53e628
commit
7829d708ea
9 changed files with 720 additions and 23 deletions
Binary file not shown.
|
|
@ -42,6 +42,7 @@ sendWebguiStats($session);
|
|||
addDataFormColumns($session);
|
||||
addListingsCacheTimeoutToMatrix( $session );
|
||||
addSurveyFeedbackTemplateColumn( $session );
|
||||
addSurveyTestResultsTemplateColumn( $session );
|
||||
installCopySender($session);
|
||||
installNotificationsSettings($session);
|
||||
installSMSUserProfileFields($session);
|
||||
|
|
@ -227,6 +228,16 @@ sub addSurveyFeedbackTemplateColumn {
|
|||
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
sub addSurveyTestResultsTemplateColumn {
|
||||
my $session = shift;
|
||||
print "\tAdding columns for Survey Test Results Template..." unless $quiet;
|
||||
$session->db->write("alter table Survey add column `testResultsTemplateId` char(22)");
|
||||
|
||||
print "Done\n" unless $quiet;
|
||||
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# Your sub here
|
||||
sub installCopySender {
|
||||
|
|
|
|||
|
|
@ -192,6 +192,14 @@ sub definition {
|
|||
defaultValue => 'PBtmpl0000000000000062',
|
||||
namespace => 'Survey/Gradebook',
|
||||
},
|
||||
testResultsTemplateId => {
|
||||
tab => 'display',
|
||||
fieldType => 'template',
|
||||
label => $i18n->get('Test Results Template'),
|
||||
hoverHelp => $i18n->get('Test Results Template help'),
|
||||
defaultValue => 'S3zpVitAmhy58CAioH359Q',
|
||||
namespace => 'Survey/TestResults',
|
||||
},
|
||||
surveyJSON => {
|
||||
fieldType => 'text',
|
||||
defaultValue => '',
|
||||
|
|
@ -2455,6 +2463,7 @@ sub www_editTestSuite {
|
|||
. $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>}
|
||||
. '</td><td>'.$name.'</td></tr>';
|
||||
}
|
||||
$tests .= '</tbody></table><div style="clear: both;"></div>';
|
||||
|
|
@ -2621,6 +2630,84 @@ sub www_promoteTest {
|
|||
return $self->www_editTestSuite;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 www_runTest ( )
|
||||
|
||||
Runs a test
|
||||
|
||||
=cut
|
||||
|
||||
sub www_runTest {
|
||||
my $self = shift;
|
||||
my $session = $self->session;
|
||||
|
||||
return $self->session->privilege->insufficient()
|
||||
unless $self->session->user->isInGroup( $self->get('groupToEditSurvey') );
|
||||
|
||||
my $id = $session->form->get("testId");
|
||||
|
||||
my $test = WebGUI::Asset::Wobject::Survey::Test->new($session, $id)
|
||||
or return $self->www_editTestSuite('Unable to find test');
|
||||
|
||||
my $result = $test->run or return $self->www_editTestSuite('Unable to run test');
|
||||
|
||||
my $tap = $result->{tap} or return $self->www_editTestSuite('Unable to determine test result');
|
||||
|
||||
$self->session->log->debug("Got tap: [$tap]");
|
||||
use TAP::Parser;
|
||||
my $parser = TAP::Parser->new( { tap => $tap } );
|
||||
|
||||
# Expose TAP::Parser and TAP::Parser::Result info as template variables
|
||||
my $var = {
|
||||
results => [],
|
||||
};
|
||||
|
||||
while ( my $result = $parser->next ) {
|
||||
my $rvar = {};
|
||||
for my $key (qw(
|
||||
is_plan is_pragma is_test is_comment is_bailout is_version is_unknown
|
||||
raw
|
||||
type
|
||||
as_string
|
||||
is_ok
|
||||
has_directive
|
||||
has_todo
|
||||
has_skip
|
||||
)) {
|
||||
$rvar->{$key} = $result->$key;
|
||||
}
|
||||
push @{$var->{results}}, $rvar;
|
||||
}
|
||||
|
||||
# add summary results
|
||||
for my $key (qw(
|
||||
passed
|
||||
failed
|
||||
actual_passed
|
||||
actual_failed
|
||||
todo
|
||||
todo_passed
|
||||
skipped
|
||||
plan
|
||||
tests_planned
|
||||
tests_run
|
||||
skip_all
|
||||
has_problems
|
||||
exit
|
||||
wait
|
||||
parse_errors
|
||||
)) {
|
||||
$var->{$key} = $parser->$key;
|
||||
}
|
||||
|
||||
my $ac = $self->getAdminConsole;
|
||||
my $out = $self->processTemplate($var, $self->get('testResultsTemplateId'));
|
||||
my $edit = WebGUI::International->new($self->session, "WebGUI")->get(575);
|
||||
$ac->addSubmenuItem($self->session->url->page("func=editTest;testId=$id"), "$edit Test");
|
||||
return $ac->render($out, 'Test Results');
|
||||
}
|
||||
|
||||
##-------------------------------------------------------------------
|
||||
#
|
||||
#=head2 www_settings ( )
|
||||
|
|
|
|||
|
|
@ -332,6 +332,49 @@ sub surveyOrder {
|
|||
return $self->response->{surveyOrder};
|
||||
}
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 surveyOrderIndexByVariableName
|
||||
|
||||
Returns a lookup table of variable names to surveyOrder index
|
||||
|
||||
Only questions with a defined variable name set are included.
|
||||
|
||||
=cut
|
||||
|
||||
sub surveyOrderIndexByVariableName {
|
||||
my $self = 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++;
|
||||
}
|
||||
|
||||
return \%lookup;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 nextResponse ([ $responseIndex ])
|
||||
|
|
|
|||
|
|
@ -1,7 +1,12 @@
|
|||
package WebGUI::Asset::Wobject::Survey::Test;
|
||||
|
||||
use strict;
|
||||
use base qw/WebGUI::Crud/;
|
||||
use WebGUI::International;
|
||||
use Test::Deep::NoTest;
|
||||
use JSON -support_by_pp; # so that we can still use allow_barekey etc..
|
||||
use Params::Validate qw(:all);
|
||||
Params::Validate::validation_options( on_fail => sub { WebGUI::Error::InvalidParam->throw( error => shift ) } );
|
||||
|
||||
=head1 NAME
|
||||
|
||||
|
|
@ -31,10 +36,6 @@ Survey_test
|
|||
|
||||
testId
|
||||
|
||||
=head3 assetId
|
||||
|
||||
testId
|
||||
|
||||
=head3 sequenceKey
|
||||
|
||||
assetId, e.g. each Survey instance has its own sequence of tests.
|
||||
|
|
@ -49,9 +50,9 @@ Identifies the Survey instance.
|
|||
|
||||
A name for the test
|
||||
|
||||
=head4 test
|
||||
=head4 spec
|
||||
|
||||
The test code
|
||||
The test spec
|
||||
|
||||
=cut
|
||||
|
||||
|
|
@ -73,16 +74,315 @@ sub crud_definition {
|
|||
hoverHelp => $i18n->get( 'test name help', 'Asset_Survey' ),
|
||||
defaultValue => '',
|
||||
};
|
||||
$properties->{test} = {
|
||||
$properties->{spec} = {
|
||||
fieldType => 'codearea',
|
||||
label => $i18n->get( 'test code', 'Asset_Survey' ),
|
||||
hoverHelp => $i18n->get( 'test code help', 'Asset_Survey' ),
|
||||
syntax => 'perl',
|
||||
defaultValue => 'test()',
|
||||
label => $i18n->get( 'test spec', 'Asset_Survey' ),
|
||||
hoverHelp => $i18n->get( 'test spec help', 'Asset_Survey' ),
|
||||
syntax => 'js',
|
||||
defaultValue => <<END_SPEC,
|
||||
[
|
||||
{
|
||||
test: {},
|
||||
},
|
||||
]
|
||||
END_SPEC
|
||||
};
|
||||
return $definition;
|
||||
}
|
||||
|
||||
1;
|
||||
=head2 run
|
||||
|
||||
#vim:ft=perl
|
||||
Run this test. Returns TAP in a hashref.
|
||||
|
||||
=cut
|
||||
|
||||
sub run {
|
||||
my $self = shift;
|
||||
my $session = $self->session;
|
||||
|
||||
if ( !$session->config->get('enableSurveyExpressionEngine') ) {
|
||||
return { tap => 'Bail Out! enableSurveyExpressionEngine config option disabled' };
|
||||
}
|
||||
|
||||
my $spec = $self->get('spec')
|
||||
or return { tap => "Bail Out! Test spec undefined" };
|
||||
|
||||
eval {
|
||||
$spec = from_json($spec, { relaxed => 1, allow_barekey => 1, allow_singlequote => 1, } );
|
||||
};
|
||||
|
||||
if ($@) {
|
||||
my $error = $@;
|
||||
$error =~ s/(.*?) at .*/$1/s; # don't reveal too much
|
||||
return { tap => "Bail Out! Invalid test spec: $error" };
|
||||
}
|
||||
|
||||
my $assetId = $self->get('assetId');
|
||||
my $survey = WebGUI::Asset::Wobject::Survey->new($session, $assetId);
|
||||
if (!$survey || !$survey->isa('WebGUI::Asset::Wobject::Survey') ) {
|
||||
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() ] );
|
||||
|
||||
# disable cookies so that test code doesn't die
|
||||
$survey->responseIdCookies(0);
|
||||
|
||||
# Start a response as current user
|
||||
my $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 %validTargets = map { $_ => 1 } @{$survey->surveyJSON->getGotoTargets};
|
||||
my $surveyOrder = $rJSON->surveyOrder;
|
||||
my $surveyOrderIndexByVariableName = $rJSON->surveyOrderIndexByVariableName;
|
||||
|
||||
# Run the tests
|
||||
my $testCount = 0;
|
||||
my @tap;
|
||||
for my $item (@$spec) {
|
||||
$self->_resetResponses($rJSON);
|
||||
$rJSON->lastResponse(-1);
|
||||
if (my $args = $item->{test} ) {
|
||||
push @tap, $self->_test( {
|
||||
responseJSON => $rJSON,
|
||||
surveyOrder => $surveyOrder,
|
||||
surveyOrderIndexByVariableName => $surveyOrderIndexByVariableName,
|
||||
args => $args,
|
||||
testCount_ref => \$testCount,
|
||||
} );
|
||||
}
|
||||
elsif (my $args = $item->{test_mc} ) {
|
||||
push @tap, $self->_test_mc( {
|
||||
responseJSON => $rJSON,
|
||||
surveyOrder => $surveyOrder,
|
||||
surveyOrderIndexByVariableName => $surveyOrderIndexByVariableName,
|
||||
args => $args,
|
||||
testCount_ref => \$testCount,
|
||||
} );
|
||||
}
|
||||
else {
|
||||
push @tap, "Bail Out!";
|
||||
}
|
||||
}
|
||||
|
||||
my $tap = "1..$testCount\n";
|
||||
$tap .= join "\n", @tap;
|
||||
return { tap => "$tap" };
|
||||
}
|
||||
|
||||
=head2 _resetResponses
|
||||
|
||||
Private convenience sub to carry out the task of resetting a response between tests
|
||||
|
||||
=cut
|
||||
|
||||
sub _resetResponses {
|
||||
my ($self, $rJSON) = @_;
|
||||
$rJSON->responses( {} );
|
||||
$rJSON->lastResponse(-1);
|
||||
}
|
||||
|
||||
=head2 _test
|
||||
|
||||
Private sub. Triggered when a test spec requests "test".
|
||||
|
||||
In the test spec, keys without special meaning are assumed to be question/section vars.
|
||||
The "next" key is special, indicating what section/question you expect the survey to
|
||||
end up at after responses have been submitted.
|
||||
|
||||
=cut
|
||||
|
||||
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 },
|
||||
});
|
||||
|
||||
# assemble the top-level ingredients..
|
||||
my $rJSON = $opts{responseJSON};
|
||||
my $surveyOrder = $opts{surveyOrder};
|
||||
my $surveyOrderIndexByVariableName = $opts{surveyOrderIndexByVariableName};
|
||||
my $args = $opts{args};
|
||||
my $testCount = ++${$opts{testCount_ref}};
|
||||
|
||||
# ..and the test-specific arguments
|
||||
my $next = $args->{next};
|
||||
delete $args->{next};
|
||||
# n.b. everything left in %args assumed to be var => answer text
|
||||
|
||||
# get starting page
|
||||
|
||||
# Record responses
|
||||
my $responses = {};
|
||||
while ( my ( $variable, $answerText ) = each %$args ) {
|
||||
my $index = $surveyOrderIndexByVariableName->{$variable};
|
||||
my $address = $surveyOrder->[$index];
|
||||
my $answerAddress;
|
||||
|
||||
my $question = $rJSON->survey->question($address);
|
||||
my $answer;
|
||||
my $aIndex = 0;
|
||||
for my $a (@{$question->{answers}}) {
|
||||
if ($a->{text} =~ m/\Q$answerText\E/i) {
|
||||
$answerAddress = "$address->[0]-$address->[1]-$aIndex";
|
||||
$answer = $a;
|
||||
}
|
||||
$aIndex++;
|
||||
}
|
||||
if (!$answer || $answerAddress !~ m/\d+-\d+-\d+/) {
|
||||
return <<END_TAP;
|
||||
not ok $testCount - next $next
|
||||
# answerText $answerText does not match any answers in your survey
|
||||
END_TAP
|
||||
}
|
||||
my $recordedAnswer = $answer->{recordedAnswer};
|
||||
$responses->{$answerAddress} = $recordedAnswer;
|
||||
$self->session->log->debug("Recording $variable ($answerAddress) => $recordedAnswer");
|
||||
}
|
||||
|
||||
return $self->_recordResponses( {
|
||||
responseJSON => $rJSON,
|
||||
responses => $responses,
|
||||
surveyOrder => $surveyOrder,
|
||||
surveyOrderIndexByVariableName => $surveyOrderIndexByVariableName,
|
||||
next => $next,
|
||||
testCount => $testCount,
|
||||
});
|
||||
}
|
||||
|
||||
=head2 _test_mc
|
||||
|
||||
Private sub. Triggered when a test spec requests "test_mc".
|
||||
|
||||
In the test spec, the first item is a section/question, and all remaining items are definitions
|
||||
of what you expect to happen next.
|
||||
|
||||
=cut
|
||||
|
||||
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 },
|
||||
});
|
||||
|
||||
# assemble the top-level ingredients..
|
||||
my $rJSON = $opts{responseJSON};
|
||||
my $surveyOrder = $opts{surveyOrder};
|
||||
my $surveyOrderIndexByVariableName = $opts{surveyOrderIndexByVariableName};
|
||||
my $args = $opts{args};
|
||||
|
||||
# the first item is the section/question
|
||||
my $variable = shift @$args;
|
||||
# ..and all remaining items are the specs
|
||||
my @specs = @$args;
|
||||
|
||||
my $index = $surveyOrderIndexByVariableName->{$variable};
|
||||
my $address = $surveyOrder->[$index];
|
||||
my $question = $rJSON->survey->question($address);
|
||||
my $answers = $question->{answers};
|
||||
|
||||
# Each spec is a sub-test, one per answer in the question
|
||||
my @tap;
|
||||
my $aIndex = 0;
|
||||
for my $spec (@specs) {
|
||||
$self->_resetResponses($rJSON);
|
||||
my $responses = {};
|
||||
my $testCount = ++${$opts{testCount_ref}};
|
||||
|
||||
# assume spec can only be a target
|
||||
my $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,
|
||||
responses => $responses,
|
||||
surveyOrder => $surveyOrder,
|
||||
surveyOrderIndexByVariableName => $surveyOrderIndexByVariableName,
|
||||
next => $next,
|
||||
testCount => $testCount,
|
||||
});
|
||||
|
||||
$aIndex++;
|
||||
}
|
||||
return @tap;
|
||||
}
|
||||
|
||||
=head2 _recordResponses
|
||||
|
||||
Private sub. Records responses and checks that you end up where you expect
|
||||
|
||||
=cut
|
||||
|
||||
sub _recordResponses {
|
||||
my $self = shift;
|
||||
my %opts = validate(@_, {
|
||||
responseJSON => { isa => 'WebGUI::Asset::Wobject::Survey::ResponseJSON' },
|
||||
responses => { type => HASHREF },
|
||||
surveyOrder => { type => ARRAYREF },
|
||||
surveyOrderIndexByVariableName => { type => HASHREF },
|
||||
next => 1,
|
||||
testCount => 1,
|
||||
});
|
||||
|
||||
# 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};
|
||||
|
||||
$rJSON->recordResponses($responses);
|
||||
|
||||
# Check where we end up
|
||||
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) {
|
||||
chomp (my $tap = <<END_TAP);
|
||||
not ok $testCount - next $next
|
||||
# Compared next section/question
|
||||
# got : $got
|
||||
# expect : $next
|
||||
END_TAP
|
||||
return $tap;
|
||||
}
|
||||
|
||||
return "ok $testCount";
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -36,7 +36,10 @@ our $HELP = {
|
|||
},
|
||||
{ tag => 'survey feedback template',
|
||||
namespace => 'Asset_Survey'
|
||||
},
|
||||
},
|
||||
{ tag => 'survey test results template',
|
||||
namespace => 'Asset_Survey'
|
||||
},
|
||||
]
|
||||
},
|
||||
|
||||
|
|
@ -102,7 +105,10 @@ our $HELP = {
|
|||
},
|
||||
{ tag => 'survey feedback template',
|
||||
namespace => 'Asset_Survey'
|
||||
},
|
||||
},
|
||||
{ tag => 'survey test results template',
|
||||
namespace => 'Asset_Survey'
|
||||
},
|
||||
]
|
||||
},
|
||||
|
||||
|
|
@ -174,6 +180,9 @@ our $HELP = {
|
|||
},
|
||||
{ tag => 'survey feedback template',
|
||||
namespace => 'Asset_Survey'
|
||||
},
|
||||
{ tag => 'survey test results template',
|
||||
namespace => 'Asset_Survey'
|
||||
},
|
||||
]
|
||||
},
|
||||
|
|
@ -221,7 +230,10 @@ our $HELP = {
|
|||
},
|
||||
{ tag => 'survey feedback template',
|
||||
namespace => 'Asset_Survey'
|
||||
},
|
||||
},
|
||||
{ tag => 'survey test results template',
|
||||
namespace => 'Asset_Survey'
|
||||
},
|
||||
]
|
||||
},
|
||||
|
||||
|
|
@ -268,7 +280,10 @@ our $HELP = {
|
|||
},
|
||||
{ tag => 'survey feedback template',
|
||||
namespace => 'Asset_Survey'
|
||||
},
|
||||
},
|
||||
{ tag => 'survey test results template',
|
||||
namespace => 'Asset_Survey'
|
||||
},
|
||||
]
|
||||
},
|
||||
|
||||
|
|
@ -310,7 +325,10 @@ our $HELP = {
|
|||
},
|
||||
{ tag => 'survey feedback template',
|
||||
namespace => 'Asset_Survey'
|
||||
},
|
||||
},
|
||||
{ tag => 'survey test results template',
|
||||
namespace => 'Asset_Survey'
|
||||
},
|
||||
]
|
||||
},
|
||||
|
||||
|
|
@ -396,6 +414,39 @@ our $HELP = {
|
|||
{ name => 'timeoutRestart', description => 'response timeout restart help' },
|
||||
{ name => 'endDate', description => 'response endDate help' },
|
||||
],
|
||||
related => [
|
||||
{ tag => 'survey template',
|
||||
namespace => 'Asset_Survey'
|
||||
},
|
||||
{ tag => 'statistical overview report template',
|
||||
namespace => 'Asset_Survey'
|
||||
},
|
||||
{ tag => 'gradebook report template',
|
||||
namespace => 'Asset_Survey'
|
||||
},
|
||||
{ tag => 'survey section edit template',
|
||||
namespace => 'Asset_Survey'
|
||||
},
|
||||
{ tag => 'survey question edit template',
|
||||
namespace => 'Asset_Survey'
|
||||
},
|
||||
{ tag => 'survey answer edit template',
|
||||
namespace => 'Asset_Survey'
|
||||
},
|
||||
{ tag => 'survey feedback template',
|
||||
namespace => 'Asset_Survey'
|
||||
},
|
||||
{ tag => 'survey test results template',
|
||||
namespace => 'Asset_Survey'
|
||||
},
|
||||
]
|
||||
},
|
||||
|
||||
'survey test results template' => {
|
||||
title => 'survey test results template title',
|
||||
body => 'survey test results template body',
|
||||
isa => [],
|
||||
fields => [],
|
||||
related => [
|
||||
{ tag => 'survey template',
|
||||
namespace => 'Asset_Survey'
|
||||
|
|
|
|||
|
|
@ -990,6 +990,16 @@ directly inside the answer_loop for other types of questions.|,
|
|||
message => q|All data tagged in survey expressions is also made available as template variables|,
|
||||
lastUpdated => 1242180657,
|
||||
},
|
||||
|
||||
'survey test results template title' => {
|
||||
message => q|Survey Test Results Template Variables|,
|
||||
lastUpdated => 1242256111,
|
||||
},
|
||||
|
||||
'survey test results template body' => {
|
||||
message => q|All TAP::Parser and TAP::Parser::Result fields are exposed as template variables|,
|
||||
lastUpdated => 0,
|
||||
},
|
||||
|
||||
'maxResponsesSubmitted' => {
|
||||
message => q|A boolean indicating whether the current user has reached the maximum number of responses.|,
|
||||
|
|
@ -1559,13 +1569,13 @@ section/answer.|,
|
|||
lastUpdated => 0,
|
||||
},
|
||||
|
||||
'test code' => {
|
||||
message => q{Test Code},
|
||||
'test spec' => {
|
||||
message => q{Test Spec},
|
||||
lastUpdated => 0,
|
||||
},
|
||||
|
||||
'test code help' => {
|
||||
message => q{The test code},
|
||||
'test spec help' => {
|
||||
message => q{The JSON-encoded specification for your test(s)},
|
||||
lastUpdated => 0,
|
||||
},
|
||||
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ my $session = WebGUI::Test->session;
|
|||
|
||||
#----------------------------------------------------------------------------
|
||||
# Tests
|
||||
my $tests = 96;
|
||||
my $tests = 97;
|
||||
plan tests => $tests + 1;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
|
@ -321,6 +321,25 @@ is($rJSON->lastResponse(), 0, 'goto: works on existing question');
|
|||
$rJSON->processGoto('goto 3-0');
|
||||
is($rJSON->lastResponse(), 5, 'goto: finds first if there are duplicates');
|
||||
|
||||
####################################################
|
||||
#
|
||||
# surveyOrderIndexByVariableName
|
||||
#
|
||||
####################################################
|
||||
my $expect = {
|
||||
'goto 0' => 0,
|
||||
'goto 0-0' => 0,
|
||||
'goto 0-1' => 1,
|
||||
'goto 0-2' => 2,
|
||||
'goto 1' => 3,
|
||||
'goto 1-0' => 3,
|
||||
'goto 1-1' => 4,
|
||||
'goto 2' => 5,
|
||||
'goto 3-0' => 7,
|
||||
'goto 3-2' => 8,
|
||||
};
|
||||
cmp_deeply($rJSON->surveyOrderIndexByVariableName(), $expect, 'surveyOrderIndexByVariableName');
|
||||
|
||||
####################################################
|
||||
#
|
||||
# responseScoresByVariableName
|
||||
|
|
|
|||
176
t/Asset/Wobject/Survey/Test.t
Normal file
176
t/Asset/Wobject/Survey/Test.t
Normal file
|
|
@ -0,0 +1,176 @@
|
|||
# Tests WebGUI::Asset::Wobject::Survey::SurveyJSON
|
||||
#
|
||||
#
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use FindBin;
|
||||
use lib "$FindBin::Bin/../../../lib";
|
||||
use Test::More;
|
||||
use Test::Deep;
|
||||
use Test::Exception;
|
||||
use Data::Dumper;
|
||||
use WebGUI::Test; # Must use this before any other WebGUI modules
|
||||
use WebGUI::Session;
|
||||
use JSON;
|
||||
use Clone qw/clone/;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# Init
|
||||
my $session = WebGUI::Test->session;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# Tests
|
||||
plan tests => 16;
|
||||
|
||||
my ( $s, $t1 );
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# put your tests here
|
||||
use_ok('WebGUI::Asset::Wobject::Survey::Test');
|
||||
|
||||
my $user = WebGUI::User->new( $session, 'new' );
|
||||
WebGUI::Test->usersToDelete($user);
|
||||
my $import_node = WebGUI::Asset->getImportNode($session);
|
||||
|
||||
# Create a Survey
|
||||
$s = $import_node->addChild( { className => 'WebGUI::Asset::Wobject::Survey', } );
|
||||
isa_ok( $s, 'WebGUI::Asset::Wobject::Survey' );
|
||||
|
||||
$s->responseIdCookies(0);
|
||||
|
||||
# Load bare-bones survey, containing a single section (S0)
|
||||
$s->surveyJSON_update( [0], { variable => 'S0' } );
|
||||
|
||||
# Section 0 has a single question, S0Q0, which is a Yes/No muti-choice
|
||||
$s->surveyJSON_newObject( [0] ); # S0Q0
|
||||
$s->surveyJSON_update( [ 0, 0 ], { variable => 'S0Q0' } );
|
||||
$s->surveyJSON->updateQuestionAnswers( [ 0, 0 ], 'Yes/No' );
|
||||
|
||||
# Add a new section (S1)
|
||||
$s->surveyJSON_newObject( [] );
|
||||
$s->surveyJSON_update( [1], { variable => 'S1' } );
|
||||
$s->surveyJSON_newObject( [1] );
|
||||
$s->surveyJSON_newObject( [1] );
|
||||
$s->surveyJSON_update( [ 1, 0 ], { variable => 'S1Q0' } );
|
||||
$s->surveyJSON_update( [ 1, 1 ], { variable => 'S1Q1' } );
|
||||
|
||||
$s->persistSurveyJSON;
|
||||
|
||||
cmp_deeply(
|
||||
$s->responseJSON->surveyOrder,
|
||||
[ [ 0, 0, [ 0, 1 ] ], [ 1, 0, [0] ], [ 1, 1, [0] ] ],
|
||||
'At this stage our surveyOrder has 3 items'
|
||||
);
|
||||
|
||||
cmp_deeply(
|
||||
$s->responseJSON->surveyOrderIndexByVariableName,
|
||||
{ 'S0' => 0,
|
||||
'S0Q0' => 0,
|
||||
'S1' => 1,
|
||||
'S1Q0' => 1,
|
||||
'S1Q1' => 2,
|
||||
},
|
||||
'..which corresponds to'
|
||||
);
|
||||
|
||||
$t1 = WebGUI::Asset::Wobject::Survey::Test->create( $session, { assetId => $s->getId } );
|
||||
my ($spec, $tap);
|
||||
|
||||
$spec = <<END_SPEC;
|
||||
[
|
||||
{
|
||||
test : {
|
||||
S0Q0 : 'Yes',
|
||||
next : "S1",
|
||||
}
|
||||
},
|
||||
{
|
||||
test : {
|
||||
S0Q0 : 'No',
|
||||
next : "S1",
|
||||
}
|
||||
}
|
||||
]
|
||||
END_SPEC
|
||||
$tap = <<END_TAP;
|
||||
1..2
|
||||
ok 1
|
||||
ok 2
|
||||
END_TAP
|
||||
try_it($t1, $spec, { tap => $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
|
||||
}
|
||||
},
|
||||
{ test : {
|
||||
S0Q0 : 'No',
|
||||
next : "S1",
|
||||
}
|
||||
} ]
|
||||
END_SPEC
|
||||
my $tap2 = <<END_TAP;
|
||||
1..2
|
||||
not ok 1 - next S1
|
||||
# Compared next section/question
|
||||
# got : S1Q1 (<-- a question)
|
||||
# expect : S1
|
||||
ok 2
|
||||
END_TAP
|
||||
try_it($t1, $spec, { tap => $tap2, fail => 1 });
|
||||
|
||||
# try now with a spec that will pass
|
||||
$spec = <<END_SPEC;
|
||||
[ { test : {
|
||||
S0Q0 : 'Yes',
|
||||
next : "S1Q1", # jumps
|
||||
}
|
||||
},
|
||||
{ test : {
|
||||
S0Q0 : 'No',
|
||||
next : "S1", # falls through
|
||||
}
|
||||
} ]
|
||||
END_SPEC
|
||||
try_it($t1, $spec, { tap => $tap });
|
||||
|
||||
# Now use test_mc
|
||||
$spec = q{ [ { test_mc : [ 'S0Q0', 'S1Q1', 'S1' ] } ] };
|
||||
try_it($t1, $spec, { tap => $tap });
|
||||
|
||||
|
||||
|
||||
use TAP::Parser;
|
||||
sub try_it {
|
||||
my ($test, $spec, $opts) = @_;
|
||||
chomp($spec);
|
||||
|
||||
$test->update( { spec => $spec } );
|
||||
my $result = $t1->run();
|
||||
ok( $result, 'Tests ran ok' );
|
||||
|
||||
if (my $tap = $opts->{tap}) {
|
||||
chomp($tap);
|
||||
is( $result->{tap}, $tap, 'TAP matches' );
|
||||
}
|
||||
|
||||
my $parser = TAP::Parser->new( $result );
|
||||
while (my $r = $parser->next) {
|
||||
# we could test extra stuff here, but mainly we just need to make the parser
|
||||
# go all the way through so that we can access ->has_problems
|
||||
}
|
||||
ok(!$parser->has_problems == !$opts->{fail}, ($opts->{fail} ? "Fails" : "Passes") . ' as expected');
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# Cleanup
|
||||
END {
|
||||
$s->purge() if $s;
|
||||
$t1->delete();
|
||||
}
|
||||
Loading…
Add table
Add a link
Reference in a new issue