diff --git a/docs/upgrades/packages-7.7.6/root_import_survey_default-test-results.wgpkg b/docs/upgrades/packages-7.7.6/root_import_survey_default-test-results.wgpkg new file mode 100644 index 000000000..a189079ba Binary files /dev/null and b/docs/upgrades/packages-7.7.6/root_import_survey_default-test-results.wgpkg differ diff --git a/docs/upgrades/upgrade_7.7.5-7.7.6.pl b/docs/upgrades/upgrade_7.7.5-7.7.6.pl index a8e42b8cc..ccdd13bb0 100644 --- a/docs/upgrades/upgrade_7.7.5-7.7.6.pl +++ b/docs/upgrades/upgrade_7.7.5-7.7.6.pl @@ -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 { diff --git a/lib/WebGUI/Asset/Wobject/Survey.pm b/lib/WebGUI/Asset/Wobject/Survey.pm index a2b25c782..ae3c70566 100644 --- a/lib/WebGUI/Asset/Wobject/Survey.pm +++ b/lib/WebGUI/Asset/Wobject/Survey.pm @@ -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{Run Test} . ''.$name.''; } $tests .= '
'; @@ -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 ( ) diff --git a/lib/WebGUI/Asset/Wobject/Survey/ResponseJSON.pm b/lib/WebGUI/Asset/Wobject/Survey/ResponseJSON.pm index 6952d57b9..c51e3cb02 100644 --- a/lib/WebGUI/Asset/Wobject/Survey/ResponseJSON.pm +++ b/lib/WebGUI/Asset/Wobject/Survey/ResponseJSON.pm @@ -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 ]) diff --git a/lib/WebGUI/Asset/Wobject/Survey/Test.pm b/lib/WebGUI/Asset/Wobject/Survey/Test.pm index 8c9f7a6bf..6aa0020bb 100644 --- a/lib/WebGUI/Asset/Wobject/Survey/Test.pm +++ b/lib/WebGUI/Asset/Wobject/Survey/Test.pm @@ -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 => <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 <{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 = < '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' diff --git a/lib/WebGUI/i18n/English/Asset_Survey.pm b/lib/WebGUI/i18n/English/Asset_Survey.pm index d5bc883ce..01352633a 100644 --- a/lib/WebGUI/i18n/English/Asset_Survey.pm +++ b/lib/WebGUI/i18n/English/Asset_Survey.pm @@ -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, }, diff --git a/t/Asset/Wobject/Survey/ResponseJSON.t b/t/Asset/Wobject/Survey/ResponseJSON.t index 7345c1f32..1da0251a6 100644 --- a/t/Asset/Wobject/Survey/ResponseJSON.t +++ b/t/Asset/Wobject/Survey/ResponseJSON.t @@ -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 diff --git a/t/Asset/Wobject/Survey/Test.t b/t/Asset/Wobject/Survey/Test.t new file mode 100644 index 000000000..06c8c1787 --- /dev/null +++ b/t/Asset/Wobject/Survey/Test.t @@ -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 = < $tap }); + +# add a goto into the mix +$s->surveyJSON_update( [ 0, 0, 0 ], { goto => 'S1Q1' } ); +# deliberately pass in a spec that will fail +$spec = < $tap2, fail => 1 }); + +# try now with a spec that will pass +$spec = < $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(); +}