diff options
| author | Nicholas Clark <nick@ccl4.org> | 2009-10-02 15:57:26 +0100 |
|---|---|---|
| committer | Nicholas Clark <nick@ccl4.org> | 2009-10-02 15:57:26 +0100 |
| commit | b8a2040150d386de90994afd87f9d01bd861104a (patch) | |
| tree | 9418ac04b77045e3bb187954c5fbf873557f7474 /cpan/Test-Harness/t | |
| parent | 8d4ff56f76907d1619ddc5fd7040d3823057ec47 (diff) | |
| download | perl-b8a2040150d386de90994afd87f9d01bd861104a.tar.gz | |
Move Test::Harness from ext/ to cpan/
Diffstat (limited to 'cpan/Test-Harness/t')
135 files changed, 14692 insertions, 0 deletions
diff --git a/cpan/Test-Harness/t/000-load.t b/cpan/Test-Harness/t/000-load.t new file mode 100644 index 0000000000..58d41bfeeb --- /dev/null +++ b/cpan/Test-Harness/t/000-load.t @@ -0,0 +1,61 @@ +#!/usr/bin/perl -wT + +use strict; +use lib 't/lib'; + +use Test::More tests => 78; + +BEGIN { + + # TAP::Parser must come first + my @classes = qw( + TAP::Parser + App::Prove + App::Prove::State + App::Prove::State::Result + App::Prove::State::Result::Test + TAP::Base + TAP::Formatter::Color + TAP::Formatter::Console::ParallelSession + TAP::Formatter::Console::Session + TAP::Formatter::Console + TAP::Harness + TAP::Parser::Aggregator + TAP::Parser::Grammar + TAP::Parser::Iterator + TAP::Parser::Iterator::Array + TAP::Parser::Iterator::Process + TAP::Parser::Iterator::Stream + TAP::Parser::IteratorFactory + TAP::Parser::Multiplexer + TAP::Parser::Result + TAP::Parser::ResultFactory + TAP::Parser::Result::Bailout + TAP::Parser::Result::Comment + TAP::Parser::Result::Plan + TAP::Parser::Result::Pragma + TAP::Parser::Result::Test + TAP::Parser::Result::Unknown + TAP::Parser::Result::Version + TAP::Parser::Result::YAML + TAP::Parser::Result + TAP::Parser::Scheduler + TAP::Parser::Scheduler::Job + TAP::Parser::Scheduler::Spinner + TAP::Parser::Source::Perl + TAP::Parser::Source + TAP::Parser::YAMLish::Reader + TAP::Parser::YAMLish::Writer + TAP::Parser::Utils + Test::Harness + ); + + foreach my $class (@classes) { + use_ok $class or BAIL_OUT("Could not load $class"); + is $class->VERSION, TAP::Parser->VERSION, + "... and $class should have the correct version"; + } + + diag("Testing Test::Harness $Test::Harness::VERSION, Perl $], $^X") + unless $ENV{PERL_CORE}; +} diff --git a/cpan/Test-Harness/t/aggregator.t b/cpan/Test-Harness/t/aggregator.t new file mode 100644 index 0000000000..c8e32a1c93 --- /dev/null +++ b/cpan/Test-Harness/t/aggregator.t @@ -0,0 +1,305 @@ +#!/usr/bin/perl -wT + +use strict; +use lib 't/lib'; + +use Test::More tests => 81; + +use TAP::Parser; +use TAP::Parser::IteratorFactory; +use TAP::Parser::Aggregator; + +my $tap = <<'END_TAP'; +1..5 +ok 1 - input file opened +... this is junk +not ok first line of the input valid # todo some data +# this is a comment +ok 3 - read the rest of the file +not ok 4 - this is a real failure +ok 5 # skip we have no description +END_TAP + +my $factory = TAP::Parser::IteratorFactory->new; +my $stream = $factory->make_iterator( [ split /\n/ => $tap ] ); +isa_ok $stream, 'TAP::Parser::Iterator'; + +my $parser1 = TAP::Parser->new( { stream => $stream } ); +isa_ok $parser1, 'TAP::Parser'; + +$parser1->run; + +$tap = <<'END_TAP'; +1..7 +ok 1 - gentlemen, start your engines +not ok first line of the input valid # todo some data +# this is a comment +ok 3 - read the rest of the file +not ok 4 - this is a real failure +ok 5 +ok 6 - you shall not pass! # TODO should have failed +not ok 7 - Gandalf wins. Game over. # TODO 'bout time! +END_TAP + +my $parser2 = TAP::Parser->new( { tap => $tap } ); +isa_ok $parser2, 'TAP::Parser'; +$parser2->run; + +can_ok 'TAP::Parser::Aggregator', 'new'; +my $agg = TAP::Parser::Aggregator->new; +isa_ok $agg, 'TAP::Parser::Aggregator'; + +can_ok $agg, 'add'; +ok $agg->add( 'tap1', $parser1 ), '... and calling it should succeed'; +ok $agg->add( 'tap2', $parser2 ), '... even if we add more than one parser'; +eval { $agg->add( 'tap1', $parser1 ) }; +like $@, qr/^You already have a parser for \Q(tap1)/, + '... but trying to reuse a description should be fatal'; + +can_ok $agg, 'parsers'; +is scalar $agg->parsers, 2, + '... and it should report how many parsers it has'; +is_deeply [ $agg->parsers ], [ $parser1, $parser2 ], + '... or which parsers it has'; +is_deeply $agg->parsers('tap2'), $parser2, '... or reporting a single parser'; +is_deeply [ $agg->parsers(qw(tap2 tap1)) ], [ $parser2, $parser1 ], + '... or a group'; + +# test aggregate results + +can_ok $agg, 'passed'; +is $agg->passed, 10, + '... and we should have the correct number of passed tests'; +is_deeply [ $agg->passed ], [qw(tap1 tap2)], + '... and be able to get their descriptions'; + +can_ok $agg, 'failed'; +is $agg->failed, 2, + '... and we should have the correct number of failed tests'; +is_deeply [ $agg->failed ], [qw(tap1 tap2)], + '... and be able to get their descriptions'; + +can_ok $agg, 'todo'; +is $agg->todo, 4, '... and we should have the correct number of todo tests'; +is_deeply [ $agg->todo ], [qw(tap1 tap2)], + '... and be able to get their descriptions'; + +can_ok $agg, 'skipped'; +is $agg->skipped, 1, + '... and we should have the correct number of skipped tests'; +is_deeply [ $agg->skipped ], [qw(tap1)], + '... and be able to get their descriptions'; + +can_ok $agg, 'parse_errors'; +is $agg->parse_errors, 0, '... and the correct number of parse errors'; +is_deeply [ $agg->parse_errors ], [], + '... and be able to get their descriptions'; + +can_ok $agg, 'todo_passed'; +is $agg->todo_passed, 1, + '... and the correct number of unexpectedly succeeded tests'; +is_deeply [ $agg->todo_passed ], [qw(tap2)], + '... and be able to get their descriptions'; + +can_ok $agg, 'total'; +is $agg->total, $agg->passed + $agg->failed, + '... and we should have the correct number of total tests'; + +can_ok $agg, 'planned'; +is $agg->planned, $agg->passed + $agg->failed, + '... and we should have the correct number of planned tests'; + +can_ok $agg, 'has_problems'; +ok $agg->has_problems, '... and it should report true if there are problems'; + +can_ok $agg, 'has_errors'; +ok $agg->has_errors, '... and it should report true if there are errors'; + +can_ok $agg, 'get_status'; +is $agg->get_status, 'FAIL', '... and it should tell us the tests failed'; + +can_ok $agg, 'all_passed'; +ok !$agg->all_passed, '... and it should tell us not all tests passed'; + +# coverage testing + +# _get_parsers +# bad descriptions +# currently the $agg object has descriptions tap1 and tap2 +# call _get_parsers with another description. +# $agg will call its _croak method +my @die; + +eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + $agg->_get_parsers('no_such_parser_for'); +}; + +is @die, 1, + 'coverage tests for missing parsers... and we caught just one death message'; +like pop(@die), + qr/^A parser for \(no_such_parser_for\) could not be found at /, + '... and it was the expected death message'; + +# _get_parsers in scalar context + +my $gp = $agg->_get_parsers(qw(tap1 tap2)) + ; # should return ref to array containing parsers for tap1 and tap2 + +is @$gp, 2, + 'coverage tests for _get_parser in scalar context... and we got the right number of parsers'; +isa_ok( $_, 'TAP::Parser' ) foreach (@$gp); + +# _get_parsers +# todo_failed - this is a deprecated method, so it (and these tests) +# can be removed eventually. However, it is showing up in the coverage +# as never tested. +my @warn; + +eval { + local $SIG{__WARN__} = sub { push @warn, @_ }; + + $agg->todo_failed(); +}; + +# check the warning, making sure to capture the fullstops correctly (not +# as "any char" matches) +is @warn, 1, + 'coverage tests for deprecated todo_failed... and just one warning caught'; +like pop(@warn), + qr/^"todo_failed" is deprecated[.] Please use "todo_passed"[.] See the docs[.] at/, + '... and it was the expected warning'; + +# has_problems +# this has a large number of conditions 'OR'd together, so the tests get +# a little complicated here + +# currently, we have covered the cases of failed() being true and none +# of the summary methods failing + +# we need to set up test cases for +# 1. !failed && todo_passed +# 2. !failed && !todo_passed && parse_errors +# 3. !failed && !todo_passed && !parse_errors && exit +# 4. !failed && !todo_passed && !parse_errors && !exit && wait + +# note there is nothing wrong per se with the has_problems logic, these +# are simply coverage tests + +# 1. !failed && todo_passed + +$agg = TAP::Parser::Aggregator->new(); +isa_ok $agg, 'TAP::Parser::Aggregator'; + +$tap = <<'END_TAP'; +1..1 +ok 1 - you shall not pass! # TODO should have failed +END_TAP + +my $parser3 = TAP::Parser->new( { tap => $tap } ); +isa_ok $parser3, 'TAP::Parser'; +$parser3->run; + +$agg->add( 'tap3', $parser3 ); + +is $agg->passed, 1, + 'coverage tests for !failed && todo_passed... and we should have the correct number of passed tests'; +is $agg->failed, 0, + '... and we should have the correct number of failed tests'; +is $agg->todo_passed, 1, + '... and the correct number of unexpectedly succeeded tests'; +ok $agg->has_problems, + '... and it should report true that there are problems'; +is $agg->get_status, 'PASS', '... and the status should be passing'; +ok !$agg->has_errors, '.... but it should not report any errors'; +ok $agg->all_passed, '... bonus tests should be passing tests, too'; + +# 2. !failed && !todo_passed && parse_errors + +$agg = TAP::Parser::Aggregator->new(); + +$tap = <<'END_TAP'; +1..-1 +END_TAP + +my $parser4 = TAP::Parser->new( { tap => $tap } ); +isa_ok $parser4, 'TAP::Parser'; +$parser4->run; + +$agg->add( 'tap4', $parser4 ); + +is $agg->passed, 0, + 'coverage tests for !failed && !todo_passed && parse_errors... and we should have the correct number of passed tests'; +is $agg->failed, 0, + '... and we should have the correct number of failed tests'; +is $agg->todo_passed, 0, + '... and the correct number of unexpectedly succeeded tests'; +is $agg->parse_errors, 1, '... and the correct number of parse errors'; +ok $agg->has_problems, + '... and it should report true that there are problems'; + +# 3. !failed && !todo_passed && !parse_errors && exit +# now this is a little harder to emulate cleanly through creating tap +# fragments and parsing, as exit and wait collect OS-status codes. +# so we'll get a little funky with $agg and push exit and wait descriptions +# in it - not very friendly to internal rep changes. + +$agg = TAP::Parser::Aggregator->new(); + +$tap = <<'END_TAP'; +1..1 +ok 1 - you shall not pass! +END_TAP + +my $parser5 = TAP::Parser->new( { tap => $tap } ); +$parser5->run; + +$agg->add( 'tap', $parser5 ); + +push @{ $agg->{descriptions_for_exit} }, 'one possible reason'; +$agg->{exit}++; + +is $agg->passed, 1, + 'coverage tests for !failed && !todo_passed && !parse_errors... and we should have the correct number of passed tests'; +is $agg->failed, 0, + '... and we should have the correct number of failed tests'; +is $agg->todo_passed, 0, + '... and the correct number of unexpectedly succeeded tests'; +is $agg->parse_errors, 0, '... and the correct number of parse errors'; + +my @exits = $agg->exit; + +is @exits, 1, '... and the correct number of exits'; +is pop(@exits), 'one possible reason', + '... and we collected the right exit reason'; + +ok $agg->has_problems, + '... and it should report true that there are problems'; + +# 4. !failed && !todo_passed && !parse_errors && !exit && wait + +$agg = TAP::Parser::Aggregator->new(); + +$agg->add( 'tap', $parser5 ); + +push @{ $agg->{descriptions_for_wait} }, 'another possible reason'; +$agg->{wait}++; + +is $agg->passed, 1, + 'coverage tests for !failed && !todo_passed && !parse_errors && !exit... and we should have the correct number of passed tests'; +is $agg->failed, 0, + '... and we should have the correct number of failed tests'; +is $agg->todo_passed, 0, + '... and the correct number of unexpectedly succeeded tests'; +is $agg->parse_errors, 0, '... and the correct number of parse errors'; +is $agg->exit, 0, '... and the correct number of exits'; + +my @waits = $agg->wait; + +is @waits, 1, '... and the correct number of waits'; +is pop(@waits), 'another possible reason', + '... and we collected the right wait reason'; + +ok $agg->has_problems, + '... and it should report true that there are problems'; diff --git a/cpan/Test-Harness/t/bailout.t b/cpan/Test-Harness/t/bailout.t new file mode 100644 index 0000000000..e10b133e0f --- /dev/null +++ b/cpan/Test-Harness/t/bailout.t @@ -0,0 +1,114 @@ +#!/usr/bin/perl -wT + +use strict; +use lib 't/lib'; + +use Test::More tests => 33; + +use TAP::Parser; + +my $tap = <<'END_TAP'; +1..4 +ok 1 - input file opened +... this is junk +not ok first line of the input valid # todo some data +# this is a comment +ok 3 - read the rest of the file +not ok 4 - this is a real failure +Bail out! We ran out of foobar. +END_TAP +my $parser = TAP::Parser->new( { tap => $tap } ); +isa_ok $parser, 'TAP::Parser', + '... we should be able to parse bailed out tests'; + +my @results; +while ( my $result = $parser->next ) { + push @results => $result; +} + +can_ok $parser, 'passed'; +is $parser->passed, 3, + '... and we shold have the correct number of passed tests'; +is_deeply [ $parser->passed ], [ 1, 2, 3 ], + '... and get a list of the passed tests'; + +can_ok $parser, 'failed'; +is $parser->failed, 1, '... and the correct number of failed tests'; +is_deeply [ $parser->failed ], [4], '... and get a list of the failed tests'; + +can_ok $parser, 'actual_passed'; +is $parser->actual_passed, 2, + '... and we shold have the correct number of actually passed tests'; +is_deeply [ $parser->actual_passed ], [ 1, 3 ], + '... and get a list of the actually passed tests'; + +can_ok $parser, 'actual_failed'; +is $parser->actual_failed, 2, + '... and the correct number of actually failed tests'; +is_deeply [ $parser->actual_failed ], [ 2, 4 ], + '... or get a list of the actually failed tests'; + +can_ok $parser, 'todo'; +is $parser->todo, 1, + '... and we should have the correct number of TODO tests'; +is_deeply [ $parser->todo ], [2], '... and get a list of the TODO tests'; + +ok !$parser->skipped, + '... and we should have the correct number of skipped tests'; + +# check the plan + +can_ok $parser, 'plan'; +is $parser->plan, '1..4', '... and we should have the correct plan'; +is $parser->tests_planned, 4, '... and the correct number of tests'; + +# results() is sane? + +ok @results, 'The parser should return results'; +is scalar @results, 8, '... and there should be one for each line'; + +# check the test plan + +my $result = shift @results; +ok $result->is_plan, 'We should have a plan'; + +# a normal, passing test + +my $test = shift @results; +ok $test->is_test, '... and a test'; + +# junk lines should be preserved + +my $unknown = shift @results; +ok $unknown->is_unknown, '... and an unknown line'; + +# a failing test, which also happens to have a directive + +my $failed = shift @results; +ok $failed->is_test, '... and another test'; + +# comments + +my $comment = shift @results; +ok $comment->is_comment, '... and a comment'; + +# another normal, passing test + +$test = shift @results; +ok $test->is_test, '... and another test'; + +# a failing test + +$failed = shift @results; +ok $failed->is_test, '... and yet another test'; + +# ok 5 # skip we have no description +# skipped test +my $bailout = shift @results; +ok $bailout->is_bailout, 'And finally we should have a bailout'; +is $bailout->as_string, 'We ran out of foobar.', + '... and as_string() should return the explanation'; +is $bailout->raw, 'Bail out! We ran out of foobar.', + '... and raw() should return the explanation'; +is $bailout->explanation, 'We ran out of foobar.', + '... and it should have the correct explanation'; diff --git a/cpan/Test-Harness/t/base.t b/cpan/Test-Harness/t/base.t new file mode 100644 index 0000000000..4fee54844e --- /dev/null +++ b/cpan/Test-Harness/t/base.t @@ -0,0 +1,173 @@ +#!/usr/bin/perl -wT + +use strict; +use lib 't/lib'; + +use Test::More tests => 38; + +use TAP::Base; + +{ + + # No callbacks allowed + can_ok 'TAP::Base', 'new'; + my $base = TAP::Base->new(); + isa_ok $base, 'TAP::Base', 'object of correct type'; + foreach my $method (qw(callback _croak _callback_for _initialize)) { + can_ok $base, $method; + } + + eval { + $base->callback( + some_event => sub { + + # do nothing + } + ); + }; + like( $@, qr/No callbacks/, 'no callbacks allowed croaks OK' ); + my $cb = $base->_callback_for('some_event'); + ok( !$cb, 'no callback installed' ); +} + +{ + + # No callbacks allowed, constructor should croak + eval { + my $base = TAP::Base->new( + { callbacks => { + some_event => sub { + + # do nothing + } + } + } + ); + }; + like( + $@, qr/No callbacks/, + 'no callbacks in constructor croaks OK' + ); +} + +package CallbackOK; + +use TAP::Base; +use vars qw(@ISA); +@ISA = 'TAP::Base'; + +sub _initialize { + my $self = shift; + my $args = shift; + $self->SUPER::_initialize( $args, [qw( nice_event other_event )] ); + return $self; +} + +package main; +{ + my $base = CallbackOK->new(); + isa_ok $base, 'TAP::Base'; + + eval { + $base->callback( + some_event => sub { + + # do nothing + } + ); + }; + like( $@, qr/Callback some_event/, 'illegal callback croaks OK' ); + + my ( $nice, $other ) = ( 0, 0 ); + + eval { + $base->callback( other_event => sub { $other-- } ); + $base->callback( nice_event => sub { $nice++; return shift() . 'OK' } + ); + }; + + ok( !$@, 'callbacks installed OK' ); + + my $nice_cbs = $base->_callback_for('nice_event'); + is( ref $nice_cbs, 'ARRAY', 'callbacks type ok' ); + is( scalar @$nice_cbs, 1, 'right number of callbacks' ); + my $nice_cb = $nice_cbs->[0]; + ok( ref $nice_cb eq 'CODE', 'callback for nice_event returned' ); + my $got = $nice_cb->('Is '); + is( $got, 'Is OK', 'args passed to callback' ); + cmp_ok( $nice, '==', 1, 'callback calls the right sub' ); + + my $other_cbs = $base->_callback_for('other_event'); + is( ref $other_cbs, 'ARRAY', 'callbacks type ok' ); + is( scalar @$other_cbs, 1, 'right number of callbacks' ); + my $other_cb = $other_cbs->[0]; + ok( ref $other_cb eq 'CODE', 'callback for other_event returned' ); + $other_cb->(); + cmp_ok( $other, '==', -1, 'callback calls the right sub' ); + + my @got = $base->_make_callback( 'nice_event', 'I am ' ); + is( scalar @got, 1, 'right number of results' ); + is( $got[0], 'I am OK', 'callback via _make_callback works' ); +} + +{ + my ( $nice, $other ) = ( 0, 0 ); + + my $base = CallbackOK->new( + { callbacks => { + nice_event => sub { $nice++ } + } + } + ); + + isa_ok $base, 'TAP::Base', 'object creation with callback succeeds'; + + eval { + $base->callback( + some_event => sub { + + # do nothing + } + ); + }; + like( $@, qr/Callback some_event/, 'illegal callback croaks OK' ); + + eval { + $base->callback( other_event => sub { $other-- } ); + }; + + ok( !$@, 'callback installed OK' ); + + my $nice_cbs = $base->_callback_for('nice_event'); + is( ref $nice_cbs, 'ARRAY', 'callbacks type ok' ); + is( scalar @$nice_cbs, 1, 'right number of callbacks' ); + my $nice_cb = $nice_cbs->[0]; + ok( ref $nice_cb eq 'CODE', 'callback for nice_event returned' ); + $nice_cb->(); + cmp_ok( $nice, '==', 1, 'callback calls the right sub' ); + + my $other_cbs = $base->_callback_for('other_event'); + is( ref $other_cbs, 'ARRAY', 'callbacks type ok' ); + is( scalar @$other_cbs, 1, 'right number of callbacks' ); + my $other_cb = $other_cbs->[0]; + ok( ref $other_cb eq 'CODE', 'callback for other_event returned' ); + $other_cb->(); + cmp_ok( $other, '==', -1, 'callback calls the right sub' ); + + # my @got = $base->_make_callback( 'nice_event', 'I am ' ); + # is ( scalar @got, 1, 'right number of results' ); + # is( $got[0], 'I am OK', 'callback via _make_callback works' ); + + my $status = undef; + + # Stack another callback + $base->callback( other_event => sub { $status = 'OK'; return 'Aye' } ); + + my $new_cbs = $base->_callback_for('other_event'); + is( ref $new_cbs, 'ARRAY', 'callbacks type ok' ); + is( scalar @$new_cbs, 2, 'right number of callbacks' ); + my $new_cb = $new_cbs->[1]; + ok( ref $new_cb eq 'CODE', 'callback for new_event returned' ); + my @got = $new_cb->(); + is( $status, 'OK', 'new callback called OK' ); +} diff --git a/cpan/Test-Harness/t/callbacks.t b/cpan/Test-Harness/t/callbacks.t new file mode 100644 index 0000000000..18c6f0d15e --- /dev/null +++ b/cpan/Test-Harness/t/callbacks.t @@ -0,0 +1,116 @@ +#!/usr/bin/perl -wT + +use strict; +use lib 't/lib'; + +use Test::More tests => 10; + +use TAP::Parser; +use TAP::Parser::IteratorFactory; + +my $tap = <<'END_TAP'; +1..5 +ok 1 - input file opened +... this is junk +not ok first line of the input valid # todo some data +# this is a comment +ok 3 - read the rest of the file +not ok 4 - this is a real failure +ok 5 # skip we have no description +END_TAP + +my @tests; +my $plan_output; +my $todo = 0; +my $skip = 0; +my %callbacks = ( + test => sub { + my $test = shift; + push @tests => $test; + $todo++ if $test->has_todo; + $skip++ if $test->has_skip; + }, + plan => sub { + my $plan = shift; + $plan_output = $plan->as_string; + } +); + +my $factory = TAP::Parser::IteratorFactory->new; +my $stream = $factory->make_iterator( [ split /\n/ => $tap ] ); +my $parser = TAP::Parser->new( + { stream => $stream, + callbacks => \%callbacks, + } +); + +can_ok $parser, 'run'; +$parser->run; +is $plan_output, '1..5', 'Plan callbacks should succeed'; +is scalar @tests, $parser->tests_run, '... as should the test callbacks'; + +@tests = (); +$plan_output = ''; +$todo = 0; +$skip = 0; +my $else = 0; +my $all = 0; +my $end = 0; +%callbacks = ( + test => sub { + my $test = shift; + push @tests => $test; + $todo++ if $test->has_todo; + $skip++ if $test->has_skip; + }, + plan => sub { + my $plan = shift; + $plan_output = $plan->as_string; + }, + EOF => sub { + my $p = shift; + $end = 1 if $all == 8 and $p->isa('TAP::Parser'); + }, + ELSE => sub { + $else++; + }, + ALL => sub { + $all++; + }, +); + +$stream = $factory->make_iterator( [ split /\n/ => $tap ] ); +$parser = TAP::Parser->new( + { stream => $stream, + callbacks => \%callbacks, + } +); + +can_ok $parser, 'run'; +$parser->run; +is $plan_output, '1..5', 'Plan callbacks should succeed'; +is scalar @tests, $parser->tests_run, '... as should the test callbacks'; +is $else, 2, '... and the correct number of "ELSE" lines should be seen'; +is $all, 8, '... and the correct total number of lines should be seen'; +is $end, 1, 'EOF callback correctly called'; + +# Check callback name policing + +%callbacks = ( + sometest => sub { }, + plan => sub { }, + random => sub { }, + ALL => sub { }, + ELSES => sub { }, +); + +$stream = $factory->make_iterator( [ split /\n/ => $tap ] ); +eval { + $parser = TAP::Parser->new( + { stream => $stream, + callbacks => \%callbacks, + } + ); +}; + +like $@, qr/Callback/, 'Bad callback keys faulted'; diff --git a/cpan/Test-Harness/t/compat/env.t b/cpan/Test-Harness/t/compat/env.t new file mode 100644 index 0000000000..ac5c096213 --- /dev/null +++ b/cpan/Test-Harness/t/compat/env.t @@ -0,0 +1,39 @@ +#!/usr/bin/perl -w + +# Test that env vars are honoured. + +use strict; +use lib 't/lib'; + +use Test::More ( + $^O eq 'VMS' + ? ( skip_all => 'VMS' ) + : ( tests => 1 ) +); + +use Test::Harness; + +# HARNESS_PERL_SWITCHES + +my $test_template = <<'END'; +#!/usr/bin/perl + +use Test::More tests => 1; + +is $ENV{HARNESS_PERL_SWITCHES}, '-w'; +END + +open TEST, ">env_check_t.tmp"; +print TEST $test_template; +close TEST; + +END { unlink 'env_check_t.tmp'; } + +{ + local $ENV{HARNESS_PERL_SWITCHES} = '-w'; + my ( $tot, $failed ) + = Test::Harness::execute_tests( tests => ['env_check_t.tmp'] ); + is $tot->{bad}, 0; +} + +1; diff --git a/cpan/Test-Harness/t/compat/failure.t b/cpan/Test-Harness/t/compat/failure.t new file mode 100644 index 0000000000..2f80e57884 --- /dev/null +++ b/cpan/Test-Harness/t/compat/failure.t @@ -0,0 +1,56 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; + +use Test::More tests => 5; + +use File::Spec; +use Test::Harness; + +{ + + #todo_skip 'Harness compatibility incomplete', 5; + #local $TODO = 'Harness compatibility incomplete'; + my $died; + + sub prepare_for_death { + $died = 0; + return sub { $died = 1 } + } + + my $curdir = File::Spec->curdir; + my $sample_tests = File::Spec->catdir( $curdir, 't', 'sample-tests' ); + + { + local $SIG{__DIE__} = prepare_for_death(); + eval { _runtests( File::Spec->catfile( $sample_tests, "simple" ) ); }; + ok( !$@, "simple lives" ); + is( $died, 0, "Death never happened" ); + } + + { + local $SIG{__DIE__} = prepare_for_death(); + eval { + _runtests( File::Spec->catfile( $sample_tests, "too_many" ) ); + }; + ok( $@, "error OK" ); + ok( $@ =~ m[Failed 1/1], "too_many dies" ); + is( $died, 1, "Death happened" ); + } +} + +sub _runtests { + my (@tests) = @_; + + local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0; + local $ENV{HARNESS_VERBOSE} = 0; + local $ENV{HARNESS_DEBUG} = 0; + local $ENV{HARNESS_TIMER} = 0; + + local $Test::Harness::Verbose = -9; + + runtests(@tests); +} + +# vim:ts=4:sw=4:et:sta diff --git a/cpan/Test-Harness/t/compat/inc-propagation.t b/cpan/Test-Harness/t/compat/inc-propagation.t new file mode 100644 index 0000000000..c0d62b0407 --- /dev/null +++ b/cpan/Test-Harness/t/compat/inc-propagation.t @@ -0,0 +1,57 @@ +#!/usr/bin/perl -w + +# Test that @INC is propogated from the harness process to the test +# process. + +use strict; +use lib 't/lib'; +use Config; + +local + $ENV{PERL5OPT}; # avoid any user-provided PERL5OPT from contaminating @INC + +sub has_crazy_patch { + my $sentinel = 'blirpzoffle'; + local $ENV{PERL5LIB} = $sentinel; + my $command = join ' ', + map {qq{"$_"}} ( $^X, '-e', 'print join q(:), @INC' ); + my $path = `$command`; + my @got = ( $path =~ /($sentinel)/g ); + return @got > 1; +} + +use Test::More ( + $^O eq 'VMS' ? ( skip_all => 'VMS' ) + : has_crazy_patch() ? ( skip_all => 'Incompatible @INC patch' ) + : ( tests => 2 ) +); + +use Test::Harness; + +# Change @INC so we ensure it's preserved. +use lib 'wibble'; + +my $test_template = <<'END'; +#!/usr/bin/perl %s + +use Test::More tests => 2; + +is $INC[0], "wibble", 'basic order of @INC preserved' or diag "\@INC: @INC"; +like $ENV{PERL5LIB}, qr{wibble}; + +END + +open TEST, ">inc_check.t.tmp"; +printf TEST $test_template, ''; +close TEST; + +open TEST, ">inc_check_taint.t.tmp"; +printf TEST $test_template, '-T'; +close TEST; +END { 1 while unlink 'inc_check_taint.t.tmp', 'inc_check.t.tmp'; } + +for my $test ( 'inc_check_taint.t.tmp', 'inc_check.t.tmp' ) { + my ( $tot, $failed ) = Test::Harness::execute_tests( tests => [$test] ); + is $tot->{bad}, 0; +} +1; diff --git a/cpan/Test-Harness/t/compat/inc_taint.t b/cpan/Test-Harness/t/compat/inc_taint.t new file mode 100644 index 0000000000..3bd86b4108 --- /dev/null +++ b/cpan/Test-Harness/t/compat/inc_taint.t @@ -0,0 +1,33 @@ +#!/usr/bin/perl -w + +use lib 't/lib'; + +use strict; + +use Test::More tests => 1; + +use Dev::Null; + +use Test::Harness; + +sub _all_ok { + my ($tot) = shift; + return $tot->{bad} == 0 + && ( $tot->{max} || $tot->{skipped} ) ? 1 : 0; +} + +{ + local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0; + local $Test::Harness::Verbose = -9; + + push @INC, 'examples'; + + tie *NULL, 'Dev::Null' or die $!; + select NULL; + my ( $tot, $failed ) = Test::Harness::execute_tests( + tests => ['t/sample-tests/inc_taint'] + ); + select STDOUT; + + ok( _all_ok($tot), 'tests with taint on preserve @INC' ); +} diff --git a/cpan/Test-Harness/t/compat/nonumbers.t b/cpan/Test-Harness/t/compat/nonumbers.t new file mode 100644 index 0000000000..144a7599b2 --- /dev/null +++ b/cpan/Test-Harness/t/compat/nonumbers.t @@ -0,0 +1,14 @@ +if ( $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE} ) { + print "1..0 # Skip: t/TEST needs numbers\n"; + exit; +} + +print <<END; +1..6 +ok +ok +ok +ok +ok +ok +END diff --git a/cpan/Test-Harness/t/compat/regression.t b/cpan/Test-Harness/t/compat/regression.t new file mode 100644 index 0000000000..50a4d516c8 --- /dev/null +++ b/cpan/Test-Harness/t/compat/regression.t @@ -0,0 +1,19 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; + +use Test::More tests => 1; +use Test::Harness; + +# 28567 +my ( @before, @after ); +{ + local @INC; + unshift @INC, 'wibble'; + @before = Test::Harness::_filtered_inc(); + unshift @INC, sub {die}; + @after = Test::Harness::_filtered_inc(); +} + +is_deeply \@after, \@before, 'subref removed from @INC'; diff --git a/cpan/Test-Harness/t/compat/switches.t b/cpan/Test-Harness/t/compat/switches.t new file mode 100644 index 0000000000..42b16c8bd4 --- /dev/null +++ b/cpan/Test-Harness/t/compat/switches.t @@ -0,0 +1,17 @@ +#!/usr/bin/perl -w + +use strict; +use Test::More ( + $^O eq 'VMS' + ? ( skip_all => 'VMS' ) + : ( tests => 4 ) +); + +use Test::Harness; + +for my $switch ( '-Ifoo', '-I foo' ) { + $Test::Harness::Switches = $switch; + ok my $harness = Test::Harness::_new_harness, 'made harness'; + is_deeply [ $harness->lib ], ['-Ifoo'], 'got libs'; +} + diff --git a/cpan/Test-Harness/t/compat/test-harness-compat.t b/cpan/Test-Harness/t/compat/test-harness-compat.t new file mode 100644 index 0000000000..cae9a54333 --- /dev/null +++ b/cpan/Test-Harness/t/compat/test-harness-compat.t @@ -0,0 +1,851 @@ +#!/usr/bin/perl -w + +BEGIN { + unshift @INC, 't/lib'; +} + +use strict; + +# use lib 't/lib'; + +use Test::More; +use File::Spec; +use Test::Harness qw(execute_tests); + +# unset this global when self-testing ('testcover' and etc issue) +local $ENV{HARNESS_PERL_SWITCHES}; + +my $TEST_DIR = 't/sample-tests'; + +{ + + # if the harness wants to save the resulting TAP we shouldn't + # do it for our internal calls + local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0; + + my $PER_LOOP = 4; + + my $results = { + 'descriptive' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 5, + 'ok' => 5, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + join( + ',', qw( + descriptive die die_head_end die_last_minute duplicates + head_end head_fail inc_taint junk_before_plan lone_not_bug + no_nums no_output schwern sequence_misparse shbang_misparse + simple simple_fail skip skip_nomsg skipall skipall_nomsg + stdout_stderr taint todo_inline + todo_misparse too_many vms_nit + ) + ) => { + 'failed' => { + "$TEST_DIR/die" => { + 'canon' => '??', + 'estat' => 1, + 'failed' => '??', + 'max' => '??', + 'name' => "$TEST_DIR/die", + 'wstat' => '256' + }, + "$TEST_DIR/die_head_end" => { + 'canon' => '??', + 'estat' => 1, + 'failed' => '??', + 'max' => '??', + 'name' => "$TEST_DIR/die_head_end", + 'wstat' => '256' + }, + "$TEST_DIR/die_last_minute" => { + 'canon' => '??', + 'estat' => 1, + 'failed' => 0, + 'max' => 4, + 'name' => "$TEST_DIR/die_last_minute", + 'wstat' => '256' + }, + "$TEST_DIR/duplicates" => { + 'canon' => '??', + 'estat' => '', + 'failed' => '??', + 'max' => 10, + 'name' => "$TEST_DIR/duplicates", + 'wstat' => '' + }, + "$TEST_DIR/head_fail" => { + 'canon' => 2, + 'estat' => '', + 'failed' => 1, + 'max' => 4, + 'name' => "$TEST_DIR/head_fail", + 'wstat' => '' + }, + "$TEST_DIR/inc_taint" => { + 'canon' => 1, + 'estat' => 1, + 'failed' => 1, + 'max' => 1, + 'name' => "$TEST_DIR/inc_taint", + 'wstat' => '256' + }, + "$TEST_DIR/no_nums" => { + 'canon' => 3, + 'estat' => '', + 'failed' => 1, + 'max' => 5, + 'name' => "$TEST_DIR/no_nums", + 'wstat' => '' + }, + "$TEST_DIR/no_output" => { + 'canon' => '??', + 'estat' => '', + 'failed' => '??', + 'max' => '??', + 'name' => "$TEST_DIR/no_output", + 'wstat' => '' + }, + "$TEST_DIR/simple_fail" => { + 'canon' => '2 5', + 'estat' => '', + 'failed' => 2, + 'max' => 5, + 'name' => "$TEST_DIR/simple_fail", + 'wstat' => '' + }, + "$TEST_DIR/todo_misparse" => { + 'canon' => 1, + 'estat' => '', + 'failed' => 1, + 'max' => 1, + 'name' => "$TEST_DIR/todo_misparse", + 'wstat' => '' + }, + "$TEST_DIR/too_many" => { + 'canon' => '4-7', + 'estat' => 4, + 'failed' => 4, + 'max' => 3, + 'name' => "$TEST_DIR/too_many", + 'wstat' => '1024' + }, + "$TEST_DIR/vms_nit" => { + 'canon' => 1, + 'estat' => '', + 'failed' => 1, + 'max' => 2, + 'name' => "$TEST_DIR/vms_nit", + 'wstat' => '' + } + }, + 'todo' => { + "$TEST_DIR/todo_inline" => { + 'canon' => 2, + 'estat' => '', + 'failed' => 1, + 'max' => 2, + 'name' => "$TEST_DIR/todo_inline", + 'wstat' => '' + } + }, + 'totals' => { + 'bad' => 12, + 'bonus' => 1, + 'files' => 27, + 'good' => 15, + 'max' => 76, + 'ok' => 78, + 'skipped' => 2, + 'sub_skipped' => 2, + 'tests' => 27, + 'todo' => 2 + } + }, + 'die' => { + 'failed' => { + "$TEST_DIR/die" => { + 'canon' => '??', + 'estat' => 1, + 'failed' => '??', + 'max' => '??', + 'name' => "$TEST_DIR/die", + 'wstat' => '256' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 0, + 'ok' => 0, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'die_head_end' => { + 'failed' => { + "$TEST_DIR/die_head_end" => { + 'canon' => '??', + 'estat' => 1, + 'failed' => '??', + 'max' => '??', + 'name' => "$TEST_DIR/die_head_end", + 'wstat' => '256' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 0, + 'ok' => 4, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'die_last_minute' => { + 'failed' => { + "$TEST_DIR/die_last_minute" => { + 'canon' => '??', + 'estat' => 1, + 'failed' => 0, + 'max' => 4, + 'name' => "$TEST_DIR/die_last_minute", + 'wstat' => '256' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 4, + 'ok' => 4, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'duplicates' => { + 'failed' => { + "$TEST_DIR/duplicates" => { + 'canon' => '??', + 'estat' => '', + 'failed' => '??', + 'max' => 10, + 'name' => "$TEST_DIR/duplicates", + 'wstat' => '' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 10, + 'ok' => 11, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'head_end' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 4, + 'ok' => 4, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'head_fail' => { + 'failed' => { + "$TEST_DIR/head_fail" => { + 'canon' => 2, + 'estat' => '', + 'failed' => 1, + 'max' => 4, + 'name' => "$TEST_DIR/head_fail", + 'wstat' => '' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 4, + 'ok' => 3, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'inc_taint' => { + 'failed' => { + "$TEST_DIR/inc_taint" => { + 'canon' => 1, + 'estat' => 1, + 'failed' => 1, + 'max' => 1, + 'name' => "$TEST_DIR/inc_taint", + 'wstat' => '256' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 1, + 'ok' => 0, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'junk_before_plan' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 1, + 'ok' => 1, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'lone_not_bug' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 4, + 'ok' => 4, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'no_nums' => { + 'failed' => { + "$TEST_DIR/no_nums" => { + 'canon' => 3, + 'estat' => '', + 'failed' => 1, + 'max' => 5, + 'name' => "$TEST_DIR/no_nums", + 'wstat' => '' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 5, + 'ok' => 4, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'no_output' => { + 'failed' => { + "$TEST_DIR/no_output" => { + 'canon' => '??', + 'estat' => '', + 'failed' => '??', + 'max' => '??', + 'name' => "$TEST_DIR/no_output", + 'wstat' => '' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 0, + 'ok' => 0, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'schwern' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 1, + 'ok' => 1, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'sequence_misparse' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 5, + 'ok' => 5, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'shbang_misparse' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 2, + 'ok' => 2, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'simple' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 5, + 'ok' => 5, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'simple_fail' => { + 'failed' => { + "$TEST_DIR/simple_fail" => { + 'canon' => '2 5', + 'estat' => '', + 'failed' => 2, + 'max' => 5, + 'name' => "$TEST_DIR/simple_fail", + 'wstat' => '' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 5, + 'ok' => 3, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'skip' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 5, + 'ok' => 5, + 'skipped' => 0, + 'sub_skipped' => 1, + 'tests' => 1, + 'todo' => 0 + } + }, + 'skip_nomsg' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 1, + 'ok' => 1, + 'skipped' => 0, + 'sub_skipped' => 1, + 'tests' => 1, + 'todo' => 0 + } + }, + 'skipall' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 0, + 'ok' => 0, + 'skipped' => 1, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'skipall_nomsg' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 0, + 'ok' => 0, + 'skipped' => 1, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'stdout_stderr' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 4, + 'ok' => 4, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'switches' => { + 'skip_if' => sub { + ( $ENV{PERL5OPT} || '' ) =~ m{(?:^|\s)-[dM]}; + }, + 'failed' => { + "$TEST_DIR/switches" => { + 'canon' => 1, + 'estat' => '', + 'failed' => 1, + 'max' => 1, + 'name' => "$TEST_DIR/switches", + 'wstat' => '' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 1, + 'ok' => 0, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'taint' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 1, + 'ok' => 1, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'taint_warn' => { + 'failed' => {}, + 'todo' => {}, + 'totals' => { + 'bad' => 0, + 'bonus' => 0, + 'files' => 1, + 'good' => 1, + 'max' => 1, + 'ok' => 1, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + }, + 'require' => 5.008001, + }, + 'todo_inline' => { + 'failed' => {}, + 'todo' => { + "$TEST_DIR/todo_inline" => { + 'canon' => 2, + 'estat' => '', + 'failed' => 1, + 'max' => 2, + 'name' => "$TEST_DIR/todo_inline", + 'wstat' => '' + } + }, + 'totals' => { + 'bad' => 0, + 'bonus' => 1, + 'files' => 1, + 'good' => 1, + 'max' => 3, + 'ok' => 3, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 2 + } + }, + 'todo_misparse' => { + 'failed' => { + "$TEST_DIR/todo_misparse" => { + 'canon' => 1, + 'estat' => '', + 'failed' => 1, + 'max' => 1, + 'name' => "$TEST_DIR/todo_misparse", + 'wstat' => '' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 1, + 'ok' => 0, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'too_many' => { + 'failed' => { + "$TEST_DIR/too_many" => { + 'canon' => '4-7', + 'estat' => 4, + 'failed' => 4, + 'max' => 3, + 'name' => "$TEST_DIR/too_many", + 'wstat' => '1024' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 3, + 'ok' => 7, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + }, + 'vms_nit' => { + 'failed' => { + "$TEST_DIR/vms_nit" => { + 'canon' => 1, + 'estat' => '', + 'failed' => 1, + 'max' => 2, + 'name' => "$TEST_DIR/vms_nit", + 'wstat' => '' + } + }, + 'todo' => {}, + 'totals' => { + 'bad' => 1, + 'bonus' => 0, + 'files' => 1, + 'good' => 0, + 'max' => 2, + 'ok' => 1, + 'skipped' => 0, + 'sub_skipped' => 0, + 'tests' => 1, + 'todo' => 0 + } + } + }; + + my $num_tests = ( keys %$results ) * $PER_LOOP; + + plan tests => $num_tests; + + sub local_name { + my $name = shift; + return File::Spec->catfile( split /\//, $name ); + } + + sub local_result { + my $hash = shift; + my $new = {}; + + while ( my ( $file, $want ) = each %$hash ) { + if ( exists $want->{name} ) { + $want->{name} = local_name( $want->{name} ); + } + $new->{ local_name($file) } = $want; + } + return $new; + } + + sub vague_status { + my $hash = shift; + return $hash unless $^O eq 'VMS'; + + while ( my ( $file, $want ) = each %$hash ) { + for (qw( estat wstat )) { + if ( exists $want->{$_} ) { + $want->{$_} = $want->{$_} ? 1 : 0; + } + } + } + return $hash; + } + + { + local $^W = 0; + + # Silence harness output + *TAP::Formatter::Console::_output = sub { + + # do nothing + }; + } + + for my $test_key ( sort keys %$results ) { + my $result = $results->{$test_key}; + SKIP: { + if ( $result->{require} && $] < $result->{require} ) { + skip "Test requires Perl $result->{require}, we have $]", 4; + } + + if ( my $skip_if = $result->{skip_if} ) { + skip + "Test '$test_key' can't run properly in this environment", 4 + if $skip_if->(); + } + + my @test_names = split( /,/, $test_key ); + my @test_files + = map { File::Spec->catfile( $TEST_DIR, $_ ) } @test_names; + + # For now we supress STDERR because it crufts up /our/ test + # results. Should probably capture and analyse it. + local ( *OLDERR, *OLDOUT ); + open OLDERR, '>&STDERR' or die $!; + open OLDOUT, '>&STDOUT' or die $!; + my $devnull = File::Spec->devnull; + open STDERR, ">$devnull" or die $!; + open STDOUT, ">$devnull" or die $!; + + my ( $tot, $fail, $todo, $harness, $aggregate ) + = execute_tests( tests => \@test_files ); + + open STDERR, '>&OLDERR' or die $!; + open STDOUT, '>&OLDOUT' or die $!; + + my $bench = delete $tot->{bench}; + isa_ok $bench, 'Benchmark'; + + # Localise filenames in failed, todo + my $lfailed = vague_status( local_result( $result->{failed} ) ); + my $ltodo = vague_status( local_result( $result->{todo} ) ); + + # use Data::Dumper; + # diag Dumper( [ $lfailed, $ltodo ] ); + + is_deeply $tot, $result->{totals}, "totals match for $test_key"; + is_deeply vague_status($fail), $lfailed, + "failure summary matches for $test_key"; + is_deeply vague_status($todo), $ltodo, + "todo summary matches for $test_key"; + } + } +} diff --git a/cpan/Test-Harness/t/compat/version.t b/cpan/Test-Harness/t/compat/version.t new file mode 100644 index 0000000000..08344cbd9c --- /dev/null +++ b/cpan/Test-Harness/t/compat/version.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl -Tw + +use strict; +use lib 't/lib'; + +use Test::More tests => 2; +use Test::Harness; + +my $ver = $ENV{HARNESS_VERSION} or die "HARNESS_VERSION not set"; +ok( $ver =~ /^[23].\d\d(_\d\d)?$/, "Version is proper format" ); +is( $ver, $Test::Harness::VERSION ); diff --git a/cpan/Test-Harness/t/console.t b/cpan/Test-Harness/t/console.t new file mode 100644 index 0000000000..32f5db62ac --- /dev/null +++ b/cpan/Test-Harness/t/console.t @@ -0,0 +1,47 @@ +use strict; +use lib 't/lib'; +use Test::More; +use TAP::Formatter::Console; + +my @schedule; + +BEGIN { + @schedule = ( + { method => '_range', + in => sub {qw/2 7 1 3 10 9/}, + out => sub {qw/1-3 7 9-10/}, + name => '... and it should return numbers as ranges' + }, + { method => '_balanced_range', + in => sub { 7, qw/2 7 1 3 10 9/ }, + out => sub { '1-3, 7', '9-10' }, + name => '... and it should return numbers as ranges' + }, + ); + + plan tests => @schedule * 3; +} + +for my $test (@schedule) { + my $name = $test->{name}; + my $cons = TAP::Formatter::Console->new; + isa_ok $cons, 'TAP::Formatter::Console'; + my $method = $test->{method}; + can_ok $cons, $method; + is_deeply [ $cons->$method( $test->{in}->() ) ], [ $test->{out}->() ], + $name; +} + +#### Color tests #### + +package Colorizer; + +sub new { bless {}, shift } +sub can_color {1} + +sub set_color { + my ( $self, $output, $color ) = @_; + $output->("[[$color]]"); +} + +package main; diff --git a/cpan/Test-Harness/t/data/catme.1 b/cpan/Test-Harness/t/data/catme.1 new file mode 100644 index 0000000000..7ecdd9a102 --- /dev/null +++ b/cpan/Test-Harness/t/data/catme.1 @@ -0,0 +1,2 @@ +1..1 +ok 1 diff --git a/cpan/Test-Harness/t/data/proverc b/cpan/Test-Harness/t/data/proverc new file mode 100644 index 0000000000..9d2924145d --- /dev/null +++ b/cpan/Test-Harness/t/data/proverc @@ -0,0 +1,7 @@ +--should be --split correctly # No comment! +Can "quote things" 'using single or' "double quotes" + +# More stuff +--this +is +'OK?' diff --git a/cpan/Test-Harness/t/data/sample.yml b/cpan/Test-Harness/t/data/sample.yml new file mode 100644 index 0000000000..6c4b7fbf4a --- /dev/null +++ b/cpan/Test-Harness/t/data/sample.yml @@ -0,0 +1,29 @@ +--- +invoice: 34843 +date : 2001-01-23 +bill-to: + given : Chris + family : Dumars + address: + lines: | + 458 Walkman Dr. + Suite #292 + city : Royal Oak + state : MI + postal : 48046 +product: + - sku : BL394D + quantity : 4 + description : Basketball + price : 450.00 + - sku : BL4438H + quantity : 1 + description : Super Hoop + price : 2392.00 +tax : 251.42 +total: 4443.52 +comments: > + Late afternoon is best. + Backup contact is Nancy + Billsmer @ 338-4338 + diff --git a/cpan/Test-Harness/t/errors.t b/cpan/Test-Harness/t/errors.t new file mode 100644 index 0000000000..3a54cbe066 --- /dev/null +++ b/cpan/Test-Harness/t/errors.t @@ -0,0 +1,183 @@ +#!/usr/bin/perl -wT + +use strict; +use lib 't/lib'; + +use Test::More tests => 23; + +use TAP::Parser; + +my $plan_line = 'TAP::Parser::Result::Plan'; +my $test_line = 'TAP::Parser::Result::Test'; + +sub _parser { + my $parser = TAP::Parser->new( { tap => shift } ); + $parser->run; + return $parser; +} + +# validate that plan! + +my $parser = _parser(<<'END_TAP'); +ok 1 - input file opened +not ok 2 - first line of the input valid # todo some data +ok 3 - read the rest of the file +1..3 +# comments are allowed after an ending plan +END_TAP + +can_ok $parser, 'parse_errors'; +ok !$parser->parse_errors, + '... comments should be allowed after a terminating plan'; + +$parser = _parser(<<'END_TAP'); +ok 1 - input file opened +not ok 2 - first line of the input valid # todo some data +ok 3 - read the rest of the file +1..3 +# yeah, yeah, I know. +ok +END_TAP + +can_ok $parser, 'parse_errors'; +is scalar $parser->parse_errors, 2, '... and we should have two parse errors'; + +is [ $parser->parse_errors ]->[0], + 'Plan (1..3) must be at the beginning or end of the TAP output', + '... telling us that our plan was misplaced'; +is [ $parser->parse_errors ]->[1], + 'Bad plan. You planned 3 tests but ran 4.', + '... and telling us we ran the wrong number of tests.'; + +$parser = _parser(<<'END_TAP'); +ok 1 - input file opened +not ok 2 - first line of the input valid # todo some data +ok 3 - read the rest of the file +#1..3 +# yo quiero tests! +1..3 +END_TAP +ok !$parser->parse_errors, '... but test plan-like data can be in a comment'; + +$parser = _parser(<<'END_TAP'); +ok 1 - input file opened +not ok 2 - first line of the input valid # todo some data +ok 3 - read the rest of the file 1..5 +# yo quiero tests! +1..3 +END_TAP +ok !$parser->parse_errors, '... or a description'; + +$parser = _parser(<<'END_TAP'); +ok 1 - input file opened +not ok 2 - first line of the input valid # todo 1..4 +ok 3 - read the rest of the file +# yo quiero tests! +1..3 +END_TAP +ok !$parser->parse_errors, '... or a directive'; + +# test numbers included? + +$parser = _parser(<<'END_TAP'); +1..3 +ok 1 - input file opened +not ok 2 - first line of the input valid # todo some data +ok read the rest of the file +# this is ... +END_TAP +eval { $parser->run }; +ok !$@, 'We can mix and match the presence of test numbers'; + +$parser = _parser(<<'END_TAP'); +1..3 +ok 1 - input file opened +not ok 2 - first line of the input valid # todo some data +ok 2 read the rest of the file +END_TAP + +is + ( $parser->parse_errors )[0], + 'Tests out of sequence. Found (2) but expected (3)', + '... and if the numbers are there, they cannot be out of sequence'; + +$parser = _parser(<<'END_TAP'); +ok 1 - input file opened +not ok 2 - first line of the input valid # todo some data +ok 2 read the rest of the file +END_TAP + +is $parser->parse_errors, 2, + 'Having two errors in the TAP should result in two errors (duh)'; +my $expected = [ + 'Tests out of sequence. Found (2) but expected (3)', + 'No plan found in TAP output' +]; +is_deeply [ $parser->parse_errors ], $expected, + '... and they should be the correct errors'; + +$parser = _parser(<<'END_TAP'); +ok 1 - input file opened +not ok 2 - first line of the input valid # todo some data +ok 3 read the rest of the file +END_TAP + +is $parser->parse_errors, 1, 'Having no plan should cause an error'; +is + ( $parser->parse_errors )[0], 'No plan found in TAP output', + '... with a correct error message'; + +$parser = _parser(<<'END_TAP'); +1..3 +ok 1 - input file opened +not ok 2 - first line of the input valid # todo some data +ok 3 read the rest of the file +1..3 +END_TAP + +is $parser->parse_errors, 1, + 'Having more than one plan should cause an error'; +is + ( $parser->parse_errors )[0], 'More than one plan found in TAP output', + '... with a correct error message'; + +can_ok $parser, 'is_good_plan'; +$parser = _parser(<<'END_TAP'); +1..2 +ok 1 - input file opened +not ok 2 - first line of the input valid # todo some data +ok 3 read the rest of the file +END_TAP + +is $parser->parse_errors, 1, + 'Having the wrong number of planned tests is a parse error'; +is + ( $parser->parse_errors )[0], + 'Bad plan. You planned 2 tests but ran 3.', + '... with a correct error message'; + +# XXX internals: plan will not set to true if defined +$parser->is_good_plan(undef); +$parser = _parser(<<'END_TAP'); +ok 1 - input file opened +1..1 +END_TAP + +ok $parser->is_good_plan, + '... and it should return true if the plan is correct'; + +# TAP::Parser coverage tests +{ + + # good_plan coverage + + my @warn; + + eval { + local $SIG{__WARN__} = sub { push @warn, @_ }; + + $parser->good_plan; + }; + + is @warn, 1, 'coverage testing of good_plan'; + + like pop @warn, + qr/good_plan[(][)] is deprecated. Please use "is_good_plan[(][)]"/, + '...and it fell-back like we expected'; +} diff --git a/cpan/Test-Harness/t/file.t b/cpan/Test-Harness/t/file.t new file mode 100644 index 0000000000..f97d1aadd0 --- /dev/null +++ b/cpan/Test-Harness/t/file.t @@ -0,0 +1,475 @@ +#!/usr/bin/perl -w + +BEGIN { + unshift @INC, 't/lib'; +} + +use strict; + +use Test::More; + +use TAP::Harness; + +my $HARNESS = 'TAP::Harness'; + +my $source_tests = 't/source_tests'; +my $sample_tests = 't/sample-tests'; + +plan tests => 56; + +# note that this test will always pass when run through 'prove' +ok $ENV{HARNESS_ACTIVE}, 'HARNESS_ACTIVE env variable should be set'; +ok $ENV{HARNESS_VERSION}, 'HARNESS_VERSION env variable should be set'; + +{ + my @output; + local $^W; + require TAP::Formatter::Base; + local *TAP::Formatter::Base::_output = sub { + my $self = shift; + push @output => grep { $_ ne '' } + map { + local $_ = $_; + chomp; + trim($_) + } map { split /\n/ } @_; + }; + + # Make sure verbosity 1 overrides failures and comments. + my $harness = TAP::Harness->new( + { verbosity => 1, + failures => 1, + comments => 1, + } + ); + my $harness_whisper = TAP::Harness->new( { verbosity => -1 } ); + my $harness_mute = TAP::Harness->new( { verbosity => -2 } ); + my $harness_directives = TAP::Harness->new( { directives => 1 } ); + my $harness_failures = TAP::Harness->new( { failures => 1 } ); + my $harness_comments = TAP::Harness->new( { comments => 1 } ); + my $harness_fandc = TAP::Harness->new( + { failures => 1, + comments => 1 + } + ); + + can_ok $harness, 'runtests'; + + # normal tests in verbose mode + + ok my $aggregate = _runtests( $harness, "$source_tests/harness" ), + '... runtests returns the aggregate'; + + isa_ok $aggregate, 'TAP::Parser::Aggregator'; + + chomp(@output); + + my @expected = ( + "$source_tests/harness ..", + '1..1', + 'ok 1 - this is a test', + 'ok', + 'All tests successful.', + ); + my $status = pop @output; + my $expected_status = qr{^Result: PASS$}; + my $summary = pop @output; + my $expected_summary = qr{^Files=1, Tests=1, \d+ wallclock secs}; + + is_deeply \@output, \@expected, '... the output should be correct'; + like $status, $expected_status, + '... and the status line should be correct'; + like $summary, $expected_summary, + '... and the report summary should look correct'; + + # use an alias for test name + + @output = (); + ok $aggregate + = _runtests( $harness, [ "$source_tests/harness", 'My Nice Test' ] ), + 'runtests returns the aggregate'; + + isa_ok $aggregate, 'TAP::Parser::Aggregator'; + + chomp(@output); + + @expected = ( + 'My Nice Test ..', + '1..1', + 'ok 1 - this is a test', + 'ok', + 'All tests successful.', + ); + $status = pop @output; + $expected_status = qr{^Result: PASS$}; + $summary = pop @output; + $expected_summary = qr{^Files=1, Tests=1, \d+ wallclock secs}; + + is_deeply \@output, \@expected, '... the output should be correct'; + like $status, $expected_status, + '... and the status line should be correct'; + like $summary, $expected_summary, + '... and the report summary should look correct'; + + # run same test twice + + @output = (); + ok $aggregate = _runtests( + $harness, [ "$source_tests/harness", 'My Nice Test' ], + [ "$source_tests/harness", 'My Nice Test Again' ] + ), + 'runtests labels returns the aggregate'; + + isa_ok $aggregate, 'TAP::Parser::Aggregator'; + + chomp(@output); + + @expected = ( + 'My Nice Test ........', + '1..1', + 'ok 1 - this is a test', + 'ok', + 'My Nice Test Again ..', + '1..1', + 'ok 1 - this is a test', + 'ok', + 'All tests successful.', + ); + $status = pop @output; + $expected_status = qr{^Result: PASS$}; + $summary = pop @output; + $expected_summary = qr{^Files=2, Tests=2, \d+ wallclock secs}; + + is_deeply \@output, \@expected, '... the output should be correct'; + like $status, $expected_status, + '... and the status line should be correct'; + like $summary, $expected_summary, + '... and the report summary should look correct'; + + # normal tests in quiet mode + + @output = (); + ok _runtests( $harness_whisper, "$source_tests/harness" ), + 'Run tests with whisper'; + + chomp(@output); + @expected = ( + "$source_tests/harness .. ok", + 'All tests successful.', + ); + + $status = pop @output; + $expected_status = qr{^Result: PASS$}; + $summary = pop @output; + $expected_summary = qr/^Files=1, Tests=1, \d+ wallclock secs/; + + is_deeply \@output, \@expected, '... the output should be correct'; + like $status, $expected_status, + '... and the status line should be correct'; + like $summary, $expected_summary, + '... and the report summary should look correct'; + + # normal tests in really_quiet mode + + @output = (); + ok _runtests( $harness_mute, "$source_tests/harness" ), 'Run tests mute'; + + chomp(@output); + @expected = ( + 'All tests successful.', + ); + + $status = pop @output; + $expected_status = qr{^Result: PASS$}; + $summary = pop @output; + $expected_summary = qr/^Files=1, Tests=1, \d+ wallclock secs/; + + is_deeply \@output, \@expected, '... the output should be correct'; + like $status, $expected_status, + '... and the status line should be correct'; + like $summary, $expected_summary, + '... and the report summary should look correct'; + + # normal tests with failures + + @output = (); + ok _runtests( $harness, "$source_tests/harness_failure" ), + 'Run tests with failures'; + + $status = pop @output; + $summary = pop @output; + + like $status, qr{^Result: FAIL$}, '... the status line should be correct'; + + my @summary = @output[ 9 .. $#output ]; + @output = @output[ 0 .. 8 ]; + + @expected = ( + "$source_tests/harness_failure ..", + '1..2', + 'ok 1 - this is a test', + 'not ok 2 - this is another test', + q{# Failed test 'this is another test'}, + '# in harness_failure.t at line 5.', + q{# got: 'waffle'}, + q{# expected: 'yarblokos'}, + 'Failed 1/2 subtests', + ); + + is_deeply \@output, \@expected, + '... and failing test output should be correct'; + + my @expected_summary = ( + 'Test Summary Report', + '-------------------', + "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", + 'Failed test:', + '2', + ); + + is_deeply \@summary, \@expected_summary, + '... and the failure summary should also be correct'; + + # quiet tests with failures + + @output = (); + ok _runtests( $harness_whisper, "$source_tests/harness_failure" ), + 'Run whisper tests with failures'; + + $status = pop @output; + $summary = pop @output; + @expected = ( + "$source_tests/harness_failure ..", + 'Failed 1/2 subtests', + 'Test Summary Report', + '-------------------', + "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", + 'Failed test:', + '2', + ); + + like $status, qr{^Result: FAIL$}, '... the status line should be correct'; + + is_deeply \@output, \@expected, + '... and failing test output should be correct'; + + # really quiet tests with failures + + @output = (); + ok _runtests( $harness_mute, "$source_tests/harness_failure" ), + 'Run mute tests with failures'; + + $status = pop @output; + $summary = pop @output; + @expected = ( + 'Test Summary Report', + '-------------------', + "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", + 'Failed test:', + '2', + ); + + like $status, qr{^Result: FAIL$}, '... the status line should be correct'; + + is_deeply \@output, \@expected, + '... and failing test output should be correct'; + + # only show directives + + @output = (); + ok _runtests( + $harness_directives, + "$source_tests/harness_directives" + ), + 'Run tests with directives'; + + chomp(@output); + + @expected = ( + "$source_tests/harness_directives ..", + 'not ok 2 - we have a something # TODO some output', + "ok 3 houston, we don't have liftoff # SKIP no funding", + 'ok', + 'All tests successful.', + + # ~TODO {{{ this should be an option + #'Test Summary Report', + #'-------------------', + #"$source_tests/harness_directives (Wstat: 0 Tests: 3 Failed: 0)", + #'Tests skipped:', + #'3', + # }}} + ); + + $status = pop @output; + $summary = pop @output; + $expected_summary = qr/^Files=1, Tests=3, \d+ wallclock secs/; + + is_deeply \@output, \@expected, '... the output should be correct'; + like $summary, $expected_summary, + '... and the report summary should look correct'; + + like $status, qr{^Result: PASS$}, + '... and the status line should be correct'; + + # normal tests with bad tap + + @output = (); + ok _runtests( $harness, "$source_tests/harness_badtap" ), + 'Run tests with bad TAP'; + chomp(@output); + + @output = map { trim($_) } @output; + $status = pop @output; + @summary = @output[ 6 .. ( $#output - 1 ) ]; + @output = @output[ 0 .. 5 ]; + @expected = ( + "$source_tests/harness_badtap ..", + '1..2', + 'ok 1 - this is a test', + 'not ok 2 - this is another test', + '1..2', + 'Failed 1/2 subtests', + ); + is_deeply \@output, \@expected, + '... failing test output should be correct'; + like $status, qr{^Result: FAIL$}, + '... and the status line should be correct'; + @expected_summary = ( + 'Test Summary Report', + '-------------------', + "$source_tests/harness_badtap (Wstat: 0 Tests: 2 Failed: 1)", + 'Failed test:', + '2', + 'Parse errors: More than one plan found in TAP output', + ); + is_deeply \@summary, \@expected_summary, + '... and the badtap summary should also be correct'; + + # coverage testing for _should_show_failures + # only show failures + + @output = (); + ok _runtests( $harness_failures, "$source_tests/harness_failure" ), + 'Run tests with failures only'; + + chomp(@output); + + @expected = ( + "$source_tests/harness_failure ..", + 'not ok 2 - this is another test', + 'Failed 1/2 subtests', + 'Test Summary Report', + '-------------------', + "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", + 'Failed test:', + '2', + ); + + $status = pop @output; + $summary = pop @output; + + like $status, qr{^Result: FAIL$}, '... the status line should be correct'; + $expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/; + is_deeply \@output, \@expected, '... and the output should be correct'; + + # check the status output for no tests + + @output = (); + ok _runtests( $harness_failures, "$sample_tests/no_output" ), + 'Run tests with failures'; + + chomp(@output); + + @expected = ( + "$sample_tests/no_output ..", + 'No subtests run', + 'Test Summary Report', + '-------------------', + "$sample_tests/no_output (Wstat: 0 Tests: 0 Failed: 0)", + 'Parse errors: No plan found in TAP output', + ); + + $status = pop @output; + $summary = pop @output; + + like $status, qr{^Result: FAIL$}, '... the status line should be correct'; + $expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/; + is_deeply \@output, \@expected, '... and the output should be correct'; + + # coverage testing for _should_show_comments + # only show comments + + @output = (); + ok _runtests( $harness_comments, "$source_tests/harness_failure" ), + 'Run tests with comments'; + chomp(@output); + + @expected = ( + "$source_tests/harness_failure ..", + q{# Failed test 'this is another test'}, + '# in harness_failure.t at line 5.', + q{# got: 'waffle'}, + q{# expected: 'yarblokos'}, + 'Failed 1/2 subtests', + 'Test Summary Report', + '-------------------', + "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", + 'Failed test:', + '2', + ); + + $status = pop @output; + $summary = pop @output; + + like $status, qr{^Result: FAIL$}, '... the status line should be correct'; + $expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/; + is_deeply \@output, \@expected, '... and the output should be correct'; + + # coverage testing for _should_show_comments and _should_show_failures + # only show comments and failures + + @output = (); + $ENV{FOO} = 1; + ok _runtests( $harness_fandc, "$source_tests/harness_failure" ), + 'Run tests with failures and comments'; + delete $ENV{FOO}; + chomp(@output); + + @expected = ( + "$source_tests/harness_failure ..", + 'not ok 2 - this is another test', + q{# Failed test 'this is another test'}, + '# in harness_failure.t at line 5.', + q{# got: 'waffle'}, + q{# expected: 'yarblokos'}, + 'Failed 1/2 subtests', + 'Test Summary Report', + '-------------------', + "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", + 'Failed test:', + '2', + ); + + $status = pop @output; + $summary = pop @output; + + like $status, qr{^Result: FAIL$}, '... the status line should be correct'; + $expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/; + is_deeply \@output, \@expected, '... and the output should be correct'; + + #XXXX +} + +sub trim { + $_[0] =~ s/^\s+|\s+$//g; + return $_[0]; +} + +sub _runtests { + my ( $harness, @tests ) = @_; + local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0; + my $aggregate = $harness->runtests(@tests); + return $aggregate; +} + diff --git a/cpan/Test-Harness/t/glob-to-regexp.t b/cpan/Test-Harness/t/glob-to-regexp.t new file mode 100644 index 0000000000..493daab307 --- /dev/null +++ b/cpan/Test-Harness/t/glob-to-regexp.t @@ -0,0 +1,44 @@ +#!/usr/bin/perl -w + +use strict; + +use Test::More; + +require TAP::Parser::Scheduler; + +my @tests; +while (<DATA>) { + my ( $glob, $pattern, $name ) = /^(\S+)\t+(\S+)(?:\t+(.*))?$/; + die "'$_'" unless $pattern; + push @tests, [ $glob, $pattern, $name ]; +} + +plan tests => scalar @tests; + +foreach (@tests) { + my ( $glob, $pattern, $name ) = @$_; + is( TAP::Parser::Scheduler->_glob_to_regexp($glob), $pattern, + defined $name ? "$glob -- $name" : $glob + ); +} +__DATA__ +Pie Pie +*.t [^/]*\.t +**.t .*?\.t +A?B A[^/]B +*/*.t [^/]*\/[^/]*\.t +A,B A\,B , outside {} not special +{A,B} (?:A|B) +A{B}C A(?:B)C +A{B,C}D A(?:B|C)D +A{B,C,D}E{F,G,H}I,J A(?:B|C|D)E(?:F|G|H)I\,J +{Perl,Rules} (?:Perl|Rules) +A}B A\}B Bare } corner case +A{B,C}D}E A(?:B|C)D\}E +},A{B,C}D},E \}\,A(?:B|C)D\}\,E +{A{1,2},D{3,4}} (?:A(?:1|2)|D(?:3|4)) +{A,{B,C},D} (?:A|(?:B|C)|D) +A{B,C\}D,E\,F}G A(?:B|C\}D|E\,F)G +A\\B A\\B +A(B)C A\(B\)C +1{A(B)C,D|E}2 1(?:A\(B\)C|D\|E)2 diff --git a/cpan/Test-Harness/t/grammar.t b/cpan/Test-Harness/t/grammar.t new file mode 100644 index 0000000000..b74fc8ba65 --- /dev/null +++ b/cpan/Test-Harness/t/grammar.t @@ -0,0 +1,455 @@ +#!/usr/bin/perl -w + +use strict; + +BEGIN { + unshift @INC, 't/lib'; +} + +use Test::More tests => 94; + +use EmptyParser; +use TAP::Parser::Grammar; +use TAP::Parser::Iterator::Array; + +my $GRAMMAR = 'TAP::Parser::Grammar'; + +# Array based stream that we can push items in to +package SS; + +sub new { + my $class = shift; + return bless [], $class; +} + +sub next { + my $self = shift; + return shift @$self; +} + +sub put { + my $self = shift; + unshift @$self, @_; +} + +sub handle_unicode { } + +package main; + +my $stream = SS->new; +my $parser = EmptyParser->new; +can_ok $GRAMMAR, 'new'; +my $grammar = $GRAMMAR->new( { stream => $stream, parser => $parser } ); +isa_ok $grammar, $GRAMMAR, '... and the object it returns'; + +# Note: all methods are actually class methods. See the docs for the reason +# why. We'll still use the instance because that should be forward +# compatible. + +my @V12 = sort qw(bailout comment plan simple_test test version); +my @V13 = sort ( @V12, 'pragma', 'yaml' ); + +can_ok $grammar, 'token_types'; +ok my @types = sort( $grammar->token_types ), + '... and calling it should succeed (v12)'; +is_deeply \@types, \@V12, '... and return the correct token types (v12)'; + +$grammar->set_version(13); +ok @types = sort( $grammar->token_types ), + '... and calling it should succeed (v13)'; +is_deeply \@types, \@V13, '... and return the correct token types (v13)'; + +can_ok $grammar, 'syntax_for'; +can_ok $grammar, 'handler_for'; + +my ( %syntax_for, %handler_for ); +foreach my $type (@types) { + ok $syntax_for{$type} = $grammar->syntax_for($type), + '... and calling syntax_for() with a type name should succeed'; + cmp_ok ref $syntax_for{$type}, 'eq', 'Regexp', + '... and it should return a regex'; + + ok $handler_for{$type} = $grammar->handler_for($type), + '... and calling handler_for() with a type name should succeed'; + cmp_ok ref $handler_for{$type}, 'eq', 'CODE', + '... and it should return a code reference'; +} + +# Test the plan. Gotta have a plan. +my $plan = '1..1'; +like $plan, $syntax_for{'plan'}, 'A basic plan should match its syntax'; + +my $method = $handler_for{'plan'}; +$plan =~ $syntax_for{'plan'}; +ok my $plan_token = $grammar->$method($plan), + '... and the handler should return a token'; + +my $expected = { + 'explanation' => '', + 'directive' => '', + 'type' => 'plan', + 'tests_planned' => 1, + 'raw' => '1..1', + 'todo_list' => [], +}; +is_deeply $plan_token, $expected, + '... and it should contain the correct data'; + +can_ok $grammar, 'tokenize'; +$stream->put($plan); +ok my $token = $grammar->tokenize, + '... and calling it with data should return a token'; +is_deeply $token, $expected, + '... and the token should contain the correct data'; + +# a plan with a skip directive + +$plan = '1..0 # SKIP why not?'; +like $plan, $syntax_for{'plan'}, 'a basic plan should match its syntax'; + +$plan =~ $syntax_for{'plan'}; +ok $plan_token = $grammar->$method($plan), + '... and the handler should return a token'; + +$expected = { + 'explanation' => 'why not?', + 'directive' => 'SKIP', + 'type' => 'plan', + 'tests_planned' => 0, + 'raw' => '1..0 # SKIP why not?', + 'todo_list' => [], +}; +is_deeply $plan_token, $expected, + '... and it should contain the correct data'; + +$stream->put($plan); +ok $token = $grammar->tokenize, + '... and calling it with data should return a token'; +is_deeply $token, $expected, + '... and the token should contain the correct data'; + +# implied skip + +$plan = '1..0'; +like $plan, $syntax_for{'plan'}, + 'A plan with an implied "skip all" should match its syntax'; + +$plan =~ $syntax_for{'plan'}; +ok $plan_token = $grammar->$method($plan), + '... and the handler should return a token'; + +$expected = { + 'explanation' => '', + 'directive' => 'SKIP', + 'type' => 'plan', + 'tests_planned' => 0, + 'raw' => '1..0', + 'todo_list' => [], +}; +is_deeply $plan_token, $expected, + '... and it should contain the correct data'; + +$stream->put($plan); +ok $token = $grammar->tokenize, + '... and calling it with data should return a token'; +is_deeply $token, $expected, + '... and the token should contain the correct data'; + +# bad plan + +$plan = '1..0 # TODO 3,4,5'; # old syntax. No longer supported +unlike $plan, $syntax_for{'plan'}, + 'Bad plans should not match the plan syntax'; + +# Bail out! + +my $bailout = 'Bail out!'; +like $bailout, $syntax_for{'bailout'}, + 'Bail out! should match a bailout syntax'; + +$stream->put($bailout); +ok $token = $grammar->tokenize, + '... and calling it with data should return a token'; +$expected = { + 'bailout' => '', + 'type' => 'bailout', + 'raw' => 'Bail out!' +}; +is_deeply $token, $expected, + '... and the token should contain the correct data'; + +$bailout = 'Bail out! some explanation'; +like $bailout, $syntax_for{'bailout'}, + 'Bail out! should match a bailout syntax'; + +$stream->put($bailout); +ok $token = $grammar->tokenize, + '... and calling it with data should return a token'; +$expected = { + 'bailout' => 'some explanation', + 'type' => 'bailout', + 'raw' => 'Bail out! some explanation' +}; +is_deeply $token, $expected, + '... and the token should contain the correct data'; + +# test comment + +my $comment = '# this is a comment'; +like $comment, $syntax_for{'comment'}, + 'Comments should match the comment syntax'; + +$stream->put($comment); +ok $token = $grammar->tokenize, + '... and calling it with data should return a token'; +$expected = { + 'comment' => 'this is a comment', + 'type' => 'comment', + 'raw' => '# this is a comment' +}; +is_deeply $token, $expected, + '... and the token should contain the correct data'; + +# test tests :/ + +my $test = 'ok 1 this is a test'; +like $test, $syntax_for{'test'}, 'Tests should match the test syntax'; + +$stream->put($test); +ok $token = $grammar->tokenize, + '... and calling it with data should return a token'; + +$expected = { + 'ok' => 'ok', + 'explanation' => '', + 'type' => 'test', + 'directive' => '', + 'description' => 'this is a test', + 'test_num' => '1', + 'raw' => 'ok 1 this is a test' +}; +is_deeply $token, $expected, + '... and the token should contain the correct data'; + +# TODO tests + +$test = 'not ok 2 this is a test # TODO whee!'; +like $test, $syntax_for{'test'}, 'Tests should match the test syntax'; + +$stream->put($test); +ok $token = $grammar->tokenize, + '... and calling it with data should return a token'; + +$expected = { + 'ok' => 'not ok', + 'explanation' => 'whee!', + 'type' => 'test', + 'directive' => 'TODO', + 'description' => 'this is a test', + 'test_num' => '2', + 'raw' => 'not ok 2 this is a test # TODO whee!' +}; +is_deeply $token, $expected, '... and the TODO should be parsed'; + +# false TODO tests + +# escaping that hash mark ('#') means this should *not* be a TODO test +$test = 'ok 22 this is a test \# TODO whee!'; +like $test, $syntax_for{'test'}, 'Tests should match the test syntax'; + +$stream->put($test); +ok $token = $grammar->tokenize, + '... and calling it with data should return a token'; + +$expected = { + 'ok' => 'ok', + 'explanation' => '', + 'type' => 'test', + 'directive' => '', + 'description' => 'this is a test \# TODO whee!', + 'test_num' => '22', + 'raw' => 'ok 22 this is a test \# TODO whee!' +}; +is_deeply $token, $expected, + '... and the token should contain the correct data'; + +# pragmas + +my $pragma = 'pragma +strict'; +like $pragma, $syntax_for{'pragma'}, 'Pragmas should match the pragma syntax'; + +$stream->put($pragma); +ok $token = $grammar->tokenize, + '... and calling it with data should return a token'; + +$expected = { + 'type' => 'pragma', + 'raw' => $pragma, + 'pragmas' => ['+strict'], +}; + +is_deeply $token, $expected, + '... and the token should contain the correct data'; + +$pragma = 'pragma +strict,-foo'; +like $pragma, $syntax_for{'pragma'}, 'Pragmas should match the pragma syntax'; + +$stream->put($pragma); +ok $token = $grammar->tokenize, + '... and calling it with data should return a token'; + +$expected = { + 'type' => 'pragma', + 'raw' => $pragma, + 'pragmas' => [ '+strict', '-foo' ], +}; + +is_deeply $token, $expected, + '... and the token should contain the correct data'; + +$pragma = 'pragma +strict , -foo '; +like $pragma, $syntax_for{'pragma'}, 'Pragmas should match the pragma syntax'; + +$stream->put($pragma); +ok $token = $grammar->tokenize, + '... and calling it with data should return a token'; + +$expected = { + 'type' => 'pragma', + 'raw' => $pragma, + 'pragmas' => [ '+strict', '-foo' ], +}; + +is_deeply $token, $expected, + '... and the token should contain the correct data'; + +# coverage tests + +# set_version + +{ + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + $grammar->set_version('no_such_version'); + }; + + unless ( is @die, 1, 'set_version with bad version' ) { + diag " >>> $_ <<<\n" for @die; + } + + like pop @die, qr/^Unsupported syntax version: no_such_version at /, + '... and got expected message'; +} + +# tokenize +{ + my $stream = SS->new; + my $parser = EmptyParser->new; + my $grammar = $GRAMMAR->new( { stream => $stream, parser => $parser } ); + + my $plan = ''; + + $stream->put($plan); + + my $result = $grammar->tokenize(); + + isa_ok $result, 'TAP::Parser::Result::Unknown'; +} + +# _make_plan_token + +{ + my $parser = EmptyParser->new; + my $grammar = $GRAMMAR->new( { parser => $parser } ); + + my $plan + = '1..1 # SKIP with explanation'; # trigger warning in _make_plan_token + + my $method = $handler_for{'plan'}; + + $plan =~ $syntax_for{'plan'}; # perform regex to populate $1, $2 + + my @warn; + + eval { + local $SIG{__WARN__} = sub { push @warn, @_ }; + + $grammar->$method($plan); + }; + + is @warn, 1, 'catch warning on inconsistent plan'; + + like pop @warn, + qr/^Specified SKIP directive in plan but more than 0 tests [(]1\.\.1 # SKIP with explanation[)]/, + '... and its what we expect'; +} + +# _make_yaml_token + +{ + my $stream = SS->new; + my $parser = EmptyParser->new; + my $grammar = $GRAMMAR->new( { stream => $stream, parser => $parser } ); + + $grammar->set_version(13); + + # now this is badly formed YAML that is missing the + # leader padding - this is done for coverage testing + # the $reader code sub in _make_yaml_token, that is + # passed as the yaml consumer to T::P::YAMLish::Reader. + + # because it isnt valid yaml, the yaml document is + # not done, and the _peek in the YAMLish::Reader + # code doesnt find the terminating '...' pattern. + # but we dont care as this is coverage testing, so + # if thats what we have to do to exercise that code, + # so be it. + my $yaml = [ ' ... ', '- 2', ' --- ', ]; + + sub iter { + my $ar = shift; + return sub { + return shift @$ar; + }; + } + + my $iter = iter($yaml); + + while ( my $line = $iter->() ) { + $stream->put($line); + } + + # pad == ' ', marker == '--- ' + # length $pad == 3 + # strip == pad + + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + $grammar->tokenize; + }; + + is @die, 1, 'checking badly formed yaml for coverage testing'; + + like pop @die, qr/^Missing '[.][.][.]' at end of YAMLish/, + '...and it died like we expect'; +} + +{ + + # coverage testing for TAP::Parser::Iterator::Array + + my $source = [qw( a b c )]; + + my $aiter = TAP::Parser::Iterator::Array->new($source); + + my $first = $aiter->next_raw; + + is $first, 'a', 'access raw iterator'; + + is $aiter->exit, undef, '... and note we didnt exhaust the source'; +} diff --git a/cpan/Test-Harness/t/harness-bailout.t b/cpan/Test-Harness/t/harness-bailout.t new file mode 100644 index 0000000000..fd1dc35669 --- /dev/null +++ b/cpan/Test-Harness/t/harness-bailout.t @@ -0,0 +1,54 @@ +#!perl + +use strict; +use File::Spec; + +BEGIN { + *CORE::GLOBAL::exit = sub { die '!exit called!' }; +} + +use TAP::Harness; +use Test::More; + +my @jobs = ( + { name => 'sequential', + args => { verbosity => -9 }, + }, + { name => 'parallel', + args => { verbosity => -9, jobs => 2 }, + }, +); + +plan tests => @jobs * 2; + +for my $test (@jobs) { + my $name = $test->{name}; + my $args = $test->{args}; + my $harness = TAP::Harness->new($args); + eval { + local ( *OLDERR, *OLDOUT ); + open OLDERR, '>&STDERR' or die $!; + open OLDOUT, '>&STDOUT' or die $!; + my $devnull = File::Spec->devnull; + open STDERR, ">$devnull" or die $!; + open STDOUT, ">$devnull" or die $!; + + $harness->runtests( + File::Spec->catfile( + 't', + 'sample-tests', + 'bailout' + ) + ); + + open STDERR, '>&OLDERR' or die $!; + open STDOUT, '>&OLDOUT' or die $!; + }; + my $err = $@; + unlike $err, qr{!exit called!}, "$name: didn't exit"; + like $err, qr{FAILED--Further testing stopped: GERONIMMMOOOOOO!!!}, + "$name: bailout message"; +} + +# vim:ts=2:sw=2:et:ft=perl + diff --git a/cpan/Test-Harness/t/harness-subclass.t b/cpan/Test-Harness/t/harness-subclass.t new file mode 100644 index 0000000000..c6b46daa21 --- /dev/null +++ b/cpan/Test-Harness/t/harness-subclass.t @@ -0,0 +1,65 @@ +#!/usr/bin/perl -w + +BEGIN { + unshift @INC, 't/lib'; +} + +use strict; +use TAP::Harness; +use Test::More tests => 13; + +my %class_map = ( + aggregator_class => 'My::TAP::Parser::Aggregator', + formatter_class => 'My::TAP::Formatter::Console', + multiplexer_class => 'My::TAP::Parser::Multiplexer', + parser_class => 'My::TAP::Parser', + scheduler_class => 'My::TAP::Parser::Scheduler', +); + +my %loaded = (); + +# Synthesize our subclasses +for my $class ( values %class_map ) { + ( my $base_class = $class ) =~ s/^My:://; + use_ok($base_class); + + no strict 'refs'; + @{"${class}::ISA"} = ($base_class); + *{"${class}::new"} = sub { + my $pkg = shift; + $loaded{$pkg} = 1; + + # Can't use SUPER outside a package + return $base_class->can('new')->( $pkg, @_ ); + }; +} + +{ + ok my $harness = TAP::Harness->new( { %class_map, verbosity => -9 } ), + 'created harness'; + isa_ok $harness, 'TAP::Harness'; + + # Test dynamic loading + ok !$INC{'NOP.pm'}, 'NOP not loaded'; + ok my $nop = $harness->_construct('NOP'), 'loaded and created'; + isa_ok $nop, 'NOP'; + ok $INC{'NOP.pm'}, 'NOP loaded'; + + my $aggregate = $harness->runtests( + File::Spec->catfile( + 't', + 'sample-tests', + 'simple' + ) + ); + + isa_ok $aggregate, 'My::TAP::Parser::Aggregator'; + + is_deeply \%loaded, + { 'My::TAP::Parser::Aggregator' => 1, + 'My::TAP::Formatter::Console' => 1, + 'My::TAP::Parser' => 1, + 'My::TAP::Parser::Scheduler' => 1, + }, + 'loaded our classes'; +} diff --git a/cpan/Test-Harness/t/harness.t b/cpan/Test-Harness/t/harness.t new file mode 100644 index 0000000000..3643f576f3 --- /dev/null +++ b/cpan/Test-Harness/t/harness.t @@ -0,0 +1,982 @@ +#!/usr/bin/perl -w + +BEGIN { + unshift @INC, 't/lib'; +} + +use strict; + +use Test::More; +use IO::c55Capture; + +use TAP::Harness; + +my $HARNESS = 'TAP::Harness'; + +my $source_tests = 't/source_tests'; +my $sample_tests = 't/sample-tests'; + +plan tests => 119; + +# note that this test will always pass when run through 'prove' +ok $ENV{HARNESS_ACTIVE}, 'HARNESS_ACTIVE env variable should be set'; +ok $ENV{HARNESS_VERSION}, 'HARNESS_VERSION env variable should be set'; + +#### For color tests #### + +package Colorizer; + +sub new { bless {}, shift } +sub can_color {1} + +sub set_color { + my ( $self, $output, $color ) = @_; + $output->("[[$color]]"); +} + +package main; + +sub colorize { + my $harness = shift; + $harness->formatter->_colorizer( Colorizer->new ); +} + +can_ok $HARNESS, 'new'; + +eval { $HARNESS->new( { no_such_key => 1 } ) }; +like $@, qr/\QUnknown arguments to TAP::Harness::new (no_such_key)/, + '... and calling it with bad keys should fail'; + +eval { $HARNESS->new( { lib => 'aint_no_such_lib' } ) }; +is $@, '', '... and calling it with a non-existent lib is fine'; + +eval { $HARNESS->new( { lib => [qw/bad_lib_1 bad_lib_2/] } ) }; +is $@, '', '... and calling it with non-existent libs is fine'; + +ok my $harness = $HARNESS->new, + 'Calling new() without arguments should succeed'; + +foreach my $test_args ( get_arg_sets() ) { + my %args = %$test_args; + foreach my $key ( sort keys %args ) { + $args{$key} = $args{$key}{in}; + } + ok my $harness = $HARNESS->new( {%args} ), + 'Calling new() with valid arguments should succeed'; + isa_ok $harness, $HARNESS, '... and the object it returns'; + + while ( my ( $property, $test ) = each %$test_args ) { + my $value = $test->{out}; + can_ok $harness, $property; + is_deeply scalar $harness->$property(), $value, $test->{test_name}; + } +} + +{ + my @output; + local $^W; + local *TAP::Formatter::Base::_output = sub { + my $self = shift; + push @output => grep { $_ ne '' } + map { + local $_ = $_; + chomp; + trim($_) + } @_; + }; + my $harness = TAP::Harness->new( + { verbosity => 1, formatter_class => "TAP::Formatter::Console" } ); + my $harness_whisper = TAP::Harness->new( + { verbosity => -1, formatter_class => "TAP::Formatter::Console" } ); + my $harness_mute = TAP::Harness->new( + { verbosity => -2, formatter_class => "TAP::Formatter::Console" } ); + my $harness_directives = TAP::Harness->new( + { directives => 1, formatter_class => "TAP::Formatter::Console" } ); + my $harness_failures = TAP::Harness->new( + { failures => 1, formatter_class => "TAP::Formatter::Console" } ); + + colorize($harness); + + can_ok $harness, 'runtests'; + + # normal tests in verbose mode + + ok my $aggregate = _runtests( $harness, "$source_tests/harness" ), + '... runtests returns the aggregate'; + + isa_ok $aggregate, 'TAP::Parser::Aggregator'; + + chomp(@output); + + my @expected = ( + "$source_tests/harness ..", + '1..1', + '[[reset]]', + 'ok 1 - this is a test', + '[[reset]]', + 'ok', + '[[green]]', + 'All tests successful.', + '[[reset]]', + ); + my $status = pop @output; + my $expected_status = qr{^Result: PASS$}; + my $summary = pop @output; + my $expected_summary = qr{^Files=1, Tests=1, \d+ wallclock secs}; + + is_deeply \@output, \@expected, '... and the output should be correct'; + like $status, $expected_status, + '... and the status line should be correct'; + like $summary, $expected_summary, + '... and the report summary should look correct'; + + # use an alias for test name + + @output = (); + ok $aggregate + = _runtests( $harness, [ "$source_tests/harness", 'My Nice Test' ] ), + '... runtests returns the aggregate'; + + isa_ok $aggregate, 'TAP::Parser::Aggregator'; + + chomp(@output); + + @expected = ( + 'My Nice Test ..', + '1..1', + '[[reset]]', + 'ok 1 - this is a test', + '[[reset]]', + 'ok', + '[[green]]', + 'All tests successful.', + '[[reset]]', + ); + $status = pop @output; + $expected_status = qr{^Result: PASS$}; + $summary = pop @output; + $expected_summary = qr{^Files=1, Tests=1, \d+ wallclock secs}; + + is_deeply \@output, \@expected, '... and the output should be correct'; + like $status, $expected_status, + '... and the status line should be correct'; + like $summary, $expected_summary, + '... and the report summary should look correct'; + + # run same test twice + + @output = (); + ok $aggregate = _runtests( + $harness, [ "$source_tests/harness", 'My Nice Test' ], + [ "$source_tests/harness", 'My Nice Test Again' ] + ), + '... runtests returns the aggregate'; + + isa_ok $aggregate, 'TAP::Parser::Aggregator'; + + chomp(@output); + + @expected = ( + 'My Nice Test ........', + '1..1', + '[[reset]]', + 'ok 1 - this is a test', + '[[reset]]', + 'ok', + 'My Nice Test Again ..', + '1..1', + '[[reset]]', + 'ok 1 - this is a test', + '[[reset]]', + 'ok', + '[[green]]', + 'All tests successful.', + '[[reset]]', + ); + $status = pop @output; + $expected_status = qr{^Result: PASS$}; + $summary = pop @output; + $expected_summary = qr{^Files=2, Tests=2, \d+ wallclock secs}; + + is_deeply \@output, \@expected, '... and the output should be correct'; + like $status, $expected_status, + '... and the status line should be correct'; + like $summary, $expected_summary, + '... and the report summary should look correct'; + + # normal tests in quiet mode + + @output = (); + _runtests( $harness_whisper, "$source_tests/harness" ); + + chomp(@output); + @expected = ( + "$source_tests/harness ..", + 'ok', + 'All tests successful.', + ); + + $status = pop @output; + $expected_status = qr{^Result: PASS$}; + $summary = pop @output; + $expected_summary = qr/^Files=1, Tests=1, \d+ wallclock secs/; + + is_deeply \@output, \@expected, '... and the output should be correct'; + like $status, $expected_status, + '... and the status line should be correct'; + like $summary, $expected_summary, + '... and the report summary should look correct'; + + # normal tests in really_quiet mode + + @output = (); + _runtests( $harness_mute, "$source_tests/harness" ); + + chomp(@output); + @expected = ( + 'All tests successful.', + ); + + $status = pop @output; + $expected_status = qr{^Result: PASS$}; + $summary = pop @output; + $expected_summary = qr/^Files=1, Tests=1, \d+ wallclock secs/; + + is_deeply \@output, \@expected, '... and the output should be correct'; + like $status, $expected_status, + '... and the status line should be correct'; + like $summary, $expected_summary, + '... and the report summary should look correct'; + + # normal tests with failures + + @output = (); + _runtests( $harness, "$source_tests/harness_failure" ); + + $status = pop @output; + $summary = pop @output; + + like $status, qr{^Result: FAIL$}, + '... and the status line should be correct'; + + my @summary = @output[ 18 .. $#output ]; + @output = @output[ 0 .. 17 ]; + + @expected = ( + "$source_tests/harness_failure ..", + '1..2', + '[[reset]]', + 'ok 1 - this is a test', + '[[reset]]', + '[[red]]', + 'not ok 2 - this is another test', + '[[reset]]', + q{# Failed test 'this is another test'}, + '[[reset]]', + '# in harness_failure.t at line 5.', + '[[reset]]', + q{# got: 'waffle'}, + '[[reset]]', + q{# expected: 'yarblokos'}, + '[[reset]]', + '[[red]]', + 'Failed 1/2 subtests', + ); + + is_deeply \@output, \@expected, + '... and failing test output should be correct'; + + my @expected_summary = ( + '[[reset]]', + 'Test Summary Report', + '-------------------', + '[[red]]', + "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", + '[[reset]]', + '[[red]]', + 'Failed test:', + '[[reset]]', + '[[red]]', + '2', + '[[reset]]', + ); + + is_deeply \@summary, \@expected_summary, + '... and the failure summary should also be correct'; + + # quiet tests with failures + + @output = (); + _runtests( $harness_whisper, "$source_tests/harness_failure" ); + + $status = pop @output; + $summary = pop @output; + @expected = ( + "$source_tests/harness_failure ..", + 'Failed 1/2 subtests', + 'Test Summary Report', + '-------------------', + "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", + 'Failed test:', + '2', + ); + + like $status, qr{^Result: FAIL$}, + '... and the status line should be correct'; + + is_deeply \@output, \@expected, + '... and failing test output should be correct'; + + # really quiet tests with failures + + @output = (); + _runtests( $harness_mute, "$source_tests/harness_failure" ); + + $status = pop @output; + $summary = pop @output; + @expected = ( + 'Test Summary Report', + '-------------------', + "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", + 'Failed test:', + '2', + ); + + like $status, qr{^Result: FAIL$}, + '... and the status line should be correct'; + + is_deeply \@output, \@expected, + '... and failing test output should be correct'; + + # only show directives + + @output = (); + _runtests( + $harness_directives, + "$source_tests/harness_directives" + ); + + chomp(@output); + + @expected = ( + "$source_tests/harness_directives ..", + 'not ok 2 - we have a something # TODO some output', + "ok 3 houston, we don't have liftoff # SKIP no funding", + 'ok', + 'All tests successful.', + + # ~TODO {{{ this should be an option + #'Test Summary Report', + #'-------------------', + #"$source_tests/harness_directives (Wstat: 0 Tests: 3 Failed: 0)", + #'Tests skipped:', + #'3', + # }}} + ); + + $status = pop @output; + $summary = pop @output; + $expected_summary = qr/^Files=1, Tests=3, \d+ wallclock secs/; + + is_deeply \@output, \@expected, '... and the output should be correct'; + like $summary, $expected_summary, + '... and the report summary should look correct'; + + like $status, qr{^Result: PASS$}, + '... and the status line should be correct'; + + # normal tests with bad tap + + # install callback handler + my $parser; + my $callback_count = 0; + + my @callback_log = (); + + for my $evt (qw(parser_args made_parser before_runtests after_runtests)) { + $harness->callback( + $evt => sub { + push @callback_log, $evt; + } + ); + } + + $harness->callback( + made_parser => sub { + $parser = shift; + $callback_count++; + } + ); + + @output = (); + _runtests( $harness, "$source_tests/harness_badtap" ); + chomp(@output); + + @output = map { trim($_) } @output; + $status = pop @output; + @summary = @output[ 12 .. ( $#output - 1 ) ]; + @output = @output[ 0 .. 11 ]; + @expected = ( + "$source_tests/harness_badtap ..", + '1..2', + '[[reset]]', + 'ok 1 - this is a test', + '[[reset]]', + '[[red]]', + 'not ok 2 - this is another test', + '[[reset]]', + '1..2', + '[[reset]]', + '[[red]]', + 'Failed 1/2 subtests', + ); + is_deeply \@output, \@expected, + '... and failing test output should be correct'; + like $status, qr{^Result: FAIL$}, + '... and the status line should be correct'; + @expected_summary = ( + '[[reset]]', + 'Test Summary Report', + '-------------------', + '[[red]]', + "$source_tests/harness_badtap (Wstat: 0 Tests: 2 Failed: 1)", + '[[reset]]', + '[[red]]', + 'Failed test:', + '[[reset]]', + '[[red]]', + '2', + '[[reset]]', + '[[red]]', + 'Parse errors: More than one plan found in TAP output', + '[[reset]]', + ); + is_deeply \@summary, \@expected_summary, + '... and the badtap summary should also be correct'; + + cmp_ok( $callback_count, '==', 1, 'callback called once' ); + is_deeply( + \@callback_log, + [ 'before_runtests', 'parser_args', 'made_parser', 'after_runtests' ], + 'callback log matches' + ); + isa_ok $parser, 'TAP::Parser'; + + # coverage testing for _should_show_failures + # only show failures + + @output = (); + _runtests( $harness_failures, "$source_tests/harness_failure" ); + + chomp(@output); + + @expected = ( + "$source_tests/harness_failure ..", + 'not ok 2 - this is another test', + 'Failed 1/2 subtests', + 'Test Summary Report', + '-------------------', + "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)", + 'Failed test:', + '2', + ); + + $status = pop @output; + $summary = pop @output; + + like $status, qr{^Result: FAIL$}, + '... and the status line should be correct'; + $expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/; + is_deeply \@output, \@expected, '... and the output should be correct'; + + # check the status output for no tests + + @output = (); + _runtests( $harness_failures, "$sample_tests/no_output" ); + + chomp(@output); + + @expected = ( + "$sample_tests/no_output ..", + 'No subtests run', + 'Test Summary Report', + '-------------------', + "$sample_tests/no_output (Wstat: 0 Tests: 0 Failed: 0)", + 'Parse errors: No plan found in TAP output', + ); + + $status = pop @output; + $summary = pop @output; + + like $status, qr{^Result: FAIL$}, + '... and the status line should be correct'; + $expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/; + is_deeply \@output, \@expected, '... and the output should be correct'; + + #XXXX +} + +# make sure we can exec something ... anything! +SKIP: { + + my $cat = '/bin/cat'; + unless ( -e $cat ) { + skip "no '$cat'", 2; + } + + my $capture = IO::c55Capture->new_handle; + my $harness = TAP::Harness->new( + { verbosity => -2, + stdout => $capture, + exec => [$cat], + } + ); + + eval { + _runtests( + $harness, + 't/data/catme.1' + ); + }; + + my @output = tied($$capture)->dump; + my $status = pop @output; + like $status, qr{^Result: PASS$}, + '... and the status line should be correct'; + pop @output; # get rid of summary line + my $answer = pop @output; + is( $answer, "All tests successful.\n", 'cat meows' ); +} + +# make sure that we can exec with a code ref. +{ + my $capture = IO::c55Capture->new_handle; + my $harness = TAP::Harness->new( + { verbosity => -2, + stdout => $capture, + exec => sub {undef}, + } + ); + + _runtests( $harness, "$source_tests/harness" ); + + my @output = tied($$capture)->dump; + my $status = pop @output; + like $status, qr{^Result: PASS$}, + '... and the status line should be correct'; + pop @output; # get rid of summary line + my $answer = pop @output; + is( $answer, "All tests successful.\n", 'cat meows' ); +} + +# Exec with a coderef that returns an arrayref +SKIP: { + my $cat = '/bin/cat'; + unless ( -e $cat ) { + skip "no '$cat'", 2; + } + + my $capture = IO::c55Capture->new_handle; + my $harness = TAP::Harness->new( + { verbosity => -2, + stdout => $capture, + exec => sub { + return [ + $cat, + 't/data/catme.1' + ]; + }, + } + ); + + _runtests( $harness, "$source_tests/harness" ); + + my @output = tied($$capture)->dump; + my $status = pop @output; + like $status, qr{^Result: PASS$}, + '... and the status line should be correct'; + pop @output; # get rid of summary line + my $answer = pop @output; + is( $answer, "All tests successful.\n", 'cat meows' ); +} + +# Exec with a coderef that returns raw TAP +{ + my $capture = IO::c55Capture->new_handle; + my $harness = TAP::Harness->new( + { verbosity => -2, + stdout => $capture, + exec => sub { + return "1..1\nok 1 - raw TAP\n"; + }, + } + ); + + _runtests( $harness, "$source_tests/harness" ); + + my @output = tied($$capture)->dump; + my $status = pop @output; + like $status, qr{^Result: PASS$}, + '... and the status line should be correct'; + pop @output; # get rid of summary line + my $answer = pop @output; + is( $answer, "All tests successful.\n", 'cat meows' ); +} + +# Exec with a coderef that returns a filehandle +{ + my $capture = IO::c55Capture->new_handle; + my $harness = TAP::Harness->new( + { verbosity => -2, + stdout => $capture, + exec => sub { + open my $fh, 't/data/catme.1'; + return $fh; + }, + } + ); + + _runtests( $harness, "$source_tests/harness" ); + + my @output = tied($$capture)->dump; + my $status = pop @output; + like $status, qr{^Result: PASS$}, + '... and the status line should be correct'; + pop @output; # get rid of summary line + my $answer = pop @output; + is( $answer, "All tests successful.\n", 'cat meows' ); +} + +# catches "exec accumulates arguments" issue (r77) +{ + my $capture = IO::c55Capture->new_handle; + my $harness = TAP::Harness->new( + { verbosity => -2, + stdout => $capture, + exec => [$^X] + } + ); + + _runtests( + $harness, + "$source_tests/harness_complain" + , # will get mad if run with args + "$source_tests/harness", + ); + + my @output = tied($$capture)->dump; + my $status = pop @output; + like $status, qr{^Result: PASS$}, + '... and the status line should be correct'; + pop @output; # get rid of summary line + is( $output[-1], "All tests successful.\n", + 'No exec accumulation' + ); +} + +sub trim { + $_[0] =~ s/^\s+|\s+$//g; + return $_[0]; +} + +sub liblist { + return [ map {"-I$_"} @_ ]; +} + +sub get_arg_sets { + + # keys are keys to new() + return { + lib => { + in => 'lib', + out => liblist('lib'), + test_name => '... a single lib switch should be correct' + }, + verbosity => { + in => 1, + out => 1, + test_name => '... and we should be able to set verbosity to 1' + }, + + # verbose => { + # in => 1, + # out => 1, + # test_name => '... and we should be able to set verbose to true' + # }, + }, + { lib => { + in => [ 'lib', 't' ], + out => liblist( 'lib', 't' ), + test_name => '... multiple lib dirs should be correct' + }, + verbosity => { + in => 0, + out => 0, + test_name => '... and we should be able to set verbosity to 0' + }, + + # verbose => { + # in => 0, + # out => 0, + # test_name => '... and we should be able to set verbose to false' + # }, + }, + { switches => { + in => [ '-T', '-w', '-T' ], + out => [ '-T', '-w', '-T' ], + test_name => '... duplicate switches should remain', + }, + failures => { + in => 1, + out => 1, + test_name => + '... and we should be able to set failures to true', + }, + verbosity => { + in => -1, + out => -1, + test_name => '... and we should be able to set verbosity to -1' + }, + + # quiet => { + # in => 1, + # out => 1, + # test_name => '... and we should be able to set quiet to false' + # }, + }, + + { verbosity => { + in => -2, + out => -2, + test_name => '... and we should be able to set verbosity to -2' + }, + + # really_quiet => { + # in => 1, + # out => 1, + # test_name => + # '... and we should be able to set really_quiet to true', + # }, + exec => { + in => $^X, + out => $^X, + test_name => + '... and we should be able to set the executable', + }, + }, + { switches => { + in => 'T', + out => ['T'], + test_name => + '... leading dashes (-) on switches are not optional', + }, + }, + { switches => { + in => '-T', + out => ['-T'], + test_name => '... we should be able to set switches', + }, + failures => { + in => 1, + out => 1, + test_name => '... and we should be able to set failures to true' + }, + }; +} + +sub _runtests { + my ( $harness, @tests ) = @_; + local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0; + my $aggregate = $harness->runtests(@tests); + return $aggregate; +} + +{ + + # coverage tests for ctor + + my $harness = TAP::Harness->new( + { timer => 0, + errors => 1, + merge => 2, + + # formatter => 3, + } + ); + + is $harness->timer(), 0, 'timer getter'; + is $harness->timer(10), 10, 'timer setter'; + is $harness->errors(), 1, 'errors getter'; + is $harness->errors(10), 10, 'errors setter'; + is $harness->merge(), 2, 'merge getter'; + is $harness->merge(10), 10, 'merge setter'; + + # jobs accessor + is $harness->jobs(), 1, 'jobs'; +} + +{ + +# coverage tests for the stdout key of VALIDATON_FOR, used by _initialize() in the ctor + + # the coverage tests are + # 1. ref $ref => false + # 2. ref => ! GLOB and ref->can(print) + # 3. ref $ref => GLOB + + # case 1 + + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + my $harness = TAP::Harness->new( + { stdout => bless {}, '0', # how evil is THAT !!! + } + ); + }; + + is @die, 1, 'bad filehandle to stdout'; + like pop @die, qr/option 'stdout' needs a filehandle/, + '... and we died as expected'; + + # case 2 + + @die = (); + + package Printable; + + sub new { return bless {}, shift } + + sub print {return} + + package main; + + my $harness = TAP::Harness->new( + { stdout => Printable->new(), + } + ); + + isa_ok $harness, 'TAP::Harness'; + + # case 3 + + @die = (); + + $harness = TAP::Harness->new( + { stdout => bless {}, 'GLOB', # again with the evil + } + ); + + isa_ok $harness, 'TAP::Harness'; +} + +{ + + # coverage testing of lib/switches accessor + my $harness = TAP::Harness->new; + + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + $harness->switches(qw( too many arguments)); + }; + + is @die, 1, 'too many arguments to accessor'; + + like pop @die, qr/Too many arguments to method 'switches'/, + '...and we died as expected'; + + $harness->switches('simple scalar'); + + my $arrref = $harness->switches; + is_deeply $arrref, ['simple scalar'], 'scalar wrapped in arr ref'; +} + +{ + + # coverage tests for the basically untested T::H::_open_spool + + my @spool = ( + ( 't', 'spool' ) + ); + $ENV{PERL_TEST_HARNESS_DUMP_TAP} = File::Spec->catfile(@spool); + +# now given that we're going to be writing stuff to the file system, make sure we have +# a cleanup hook + + END { + use File::Path; + + # remove the tree if we made it this far + rmtree( $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) + if $ENV{PERL_TEST_HARNESS_DUMP_TAP}; + } + + my $harness = TAP::Harness->new( { verbosity => -2 } ); + + can_ok $harness, 'runtests'; + + # normal tests in verbose mode + + my $parser + = $harness->runtests( File::Spec->catfile( $source_tests, 'harness' ) ); + + isa_ok $parser, 'TAP::Parser::Aggregator', + '... runtests returns the aggregate'; + + ok -e File::Spec->catfile( + $ENV{PERL_TEST_HARNESS_DUMP_TAP}, + $source_tests, 'harness' + ); +} + +{ + + # test name munging + my @cases = ( + { name => 'all the same', + input => [ 'foo.t', 'bar.t', 'fletz.t' ], + output => [ + [ 'foo.t', 'foo.t' ], [ 'bar.t', 'bar.t' ], + [ 'fletz.t', 'fletz.t' ] + ], + }, + { name => 'all the same, already cooked', + input => [ 'foo.t', [ 'bar.t', 'brip' ], 'fletz.t' ], + output => [ + [ 'foo.t', 'foo.t' ], [ 'bar.t', 'brip' ], + [ 'fletz.t', 'fletz.t' ] + ], + }, + { name => 'different exts', + input => [ 'foo.t', 'bar.u', 'fletz.v' ], + output => [ + [ 'foo.t', 'foo.t' ], [ 'bar.u', 'bar.u' ], + [ 'fletz.v', 'fletz.v' ] + ], + }, + { name => 'different exts, one already cooked', + input => [ 'foo.t', [ 'bar.u', 'bam' ], 'fletz.v' ], + output => [ + [ 'foo.t', 'foo.t' ], [ 'bar.u', 'bam' ], + [ 'fletz.v', 'fletz.v' ] + ], + }, + { name => 'different exts, two already cooked', + input => [ 'foo.t', [ 'bar.u', 'bam.q' ], [ 'fletz.v', 'boo' ] ], + output => [ + [ 'foo.t', 'foo.t' ], [ 'bar.u', 'bam.q' ], + [ 'fletz.v', 'boo' ] + ], + }, + ); + + for my $case (@cases) { + is_deeply [ TAP::Harness->_add_descriptions( @{ $case->{input} } ) ], + $case->{output}, '_add_descriptions: ' . $case->{name}; + } +} diff --git a/cpan/Test-Harness/t/iterators.t b/cpan/Test-Harness/t/iterators.t new file mode 100644 index 0000000000..d190be9289 --- /dev/null +++ b/cpan/Test-Harness/t/iterators.t @@ -0,0 +1,215 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; + +use Test::More tests => 76; + +use File::Spec; +use TAP::Parser; +use TAP::Parser::IteratorFactory; +use Config; + +sub array_ref_from { + my $string = shift; + my @lines = split /\n/ => $string; + return \@lines; +} + +# we slurp __DATA__ and then reset it so we don't have to duplicate our TAP +my $offset = tell DATA; +my $tap = do { local $/; <DATA> }; +seek DATA, $offset, 0; + +my $did_setup = 0; +my $did_teardown = 0; + +my $setup = sub { $did_setup++ }; +my $teardown = sub { $did_teardown++ }; + +package NoForkProcess; +use vars qw( @ISA ); +@ISA = qw( TAP::Parser::Iterator::Process ); + +sub _use_open3 {return} + +package main; + +my @schedule = ( + { name => 'Process', + subclass => 'TAP::Parser::Iterator::Process', + source => { + command => [ + $^X, + File::Spec->catfile( + 't', + 'sample-tests', + 'out_err_mix' + ) + ], + merge => 1, + setup => $setup, + teardown => $teardown, + }, + after => sub { + is $did_setup, 1, "setup called"; + is $did_teardown, 1, "teardown called"; + }, + need_open3 => 15, + }, + { name => 'Array', + subclass => 'TAP::Parser::Iterator::Array', + source => array_ref_from($tap), + }, + { name => 'Stream', + subclass => 'TAP::Parser::Iterator::Stream', + source => \*DATA, + }, + { name => 'Process (Perl -e)', + subclass => 'TAP::Parser::Iterator::Process', + source => + { command => [ $^X, '-e', 'print qq/one\ntwo\n\nthree\n/' ] }, + }, + { name => 'Process (NoFork)', + subclass => 'TAP::Parser::Iterator::Process', + class => 'NoForkProcess', + source => + { command => [ $^X, '-e', 'print qq/one\ntwo\n\nthree\n/' ] }, + }, +); + +sub _can_open3 { + return $Config{d_fork}; +} + +my $factory = TAP::Parser::IteratorFactory->new; +for my $test (@schedule) { + SKIP: { + my $name = $test->{name}; + my $need_open3 = $test->{need_open3}; + skip "No open3", $need_open3 if $need_open3 && !_can_open3(); + my $subclass = $test->{subclass}; + my $source = $test->{source}; + my $class = $test->{class}; + my $iter + = $class + ? $class->new($source) + : $factory->make_iterator($source); + ok $iter, "$name: We should be able to create a new iterator"; + isa_ok $iter, 'TAP::Parser::Iterator', + '... and the object it returns'; + isa_ok $iter, $subclass, '... and the object it returns'; + + can_ok $iter, 'exit'; + ok !defined $iter->exit, + "$name: ... and it should be undef before we are done ($subclass)"; + + can_ok $iter, 'next'; + is $iter->next, 'one', "$name: next() should return the first result"; + + is $iter->next, 'two', + "$name: next() should return the second result"; + + is $iter->next, '', "$name: next() should return the third result"; + + is $iter->next, 'three', + "$name: next() should return the fourth result"; + + ok !defined $iter->next, + "$name: next() should return undef after it is empty"; + + is $iter->exit, 0, + "$name: ... and exit should now return 0 ($subclass)"; + + is $iter->wait, 0, "$name: wait should also now return 0 ($subclass)"; + + if ( my $after = $test->{after} ) { + $after->(); + } + } +} + +{ + + # coverage tests for the ctor + + my $stream = $factory->make_iterator( IO::Handle->new ); + + isa_ok $stream, 'TAP::Parser::Iterator::Stream'; + + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + $factory->make_iterator( \1 ); # a ref to a scalar + }; + + is @die, 1, 'coverage of error case'; + + like pop @die, qr/Can't iterate with a SCALAR/, + '...and we died as expected'; +} + +{ + + # coverage test for VMS case + + my $stream = $factory->make_iterator( + [ 'not ', + 'ok 1 - I hate VMS', + ] + ); + + is $stream->next, 'not ok 1 - I hate VMS', + 'coverage of VMS line-splitting case'; + + # coverage test for VMS case - nothing after 'not' + + $stream = $factory->make_iterator( + [ 'not ', + ] + ); + + is $stream->next, 'not ', '...and we find "not" by itself'; +} + +SKIP: { + skip "No open3", 4 unless _can_open3(); + + # coverage testing for TAP::Parser::Iterator::Process ctor + + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + $factory->make_iterator( {} ); + }; + + is @die, 1, 'coverage testing for TPI::Process'; + + like pop @die, qr/Must supply a command to execute/, + '...and we died as expected'; + + my $parser = $factory->make_iterator( + { command => [ + $^X, + File::Spec->catfile( 't', 'sample-tests', 'out_err_mix' ) + ], + merge => 1, + } + ); + + is $parser->{err}, '', 'confirm we set err to empty string'; + is $parser->{sel}, undef, '...and selector to undef'; + + # And then we read from the parser to sidestep the Mac OS / open3 + # bug which frequently throws an error here otherwise. + $parser->next; +} +__DATA__ +one +two + +three diff --git a/cpan/Test-Harness/t/lib/App/Prove/Plugin/Dummy.pm b/cpan/Test-Harness/t/lib/App/Prove/Plugin/Dummy.pm new file mode 100644 index 0000000000..81f79ea042 --- /dev/null +++ b/cpan/Test-Harness/t/lib/App/Prove/Plugin/Dummy.pm @@ -0,0 +1,9 @@ +package App::Prove::Plugin::Dummy; + +use strict; + +sub import { + main::test_log_import(@_); +} + +1; diff --git a/cpan/Test-Harness/t/lib/App/Prove/Plugin/Dummy2.pm b/cpan/Test-Harness/t/lib/App/Prove/Plugin/Dummy2.pm new file mode 100644 index 0000000000..ae80003e62 --- /dev/null +++ b/cpan/Test-Harness/t/lib/App/Prove/Plugin/Dummy2.pm @@ -0,0 +1,13 @@ +package App::Prove::Plugin::Dummy2; + +use strict; + +sub import { + main::test_log_import(@_); +} + +sub load { + main::test_log_plugin_load(@_); +} + +1; diff --git a/cpan/Test-Harness/t/lib/Dev/Null.pm b/cpan/Test-Harness/t/lib/Dev/Null.pm new file mode 100644 index 0000000000..09ca5d6627 --- /dev/null +++ b/cpan/Test-Harness/t/lib/Dev/Null.pm @@ -0,0 +1,18 @@ +# For shutting up Test::Harness. +# Has to work on 5.004 which doesn't have Tie::StdHandle. +package Dev::Null; + +sub WRITE { } +sub PRINT { } +sub PRINTF { } + +sub TIEHANDLE { + my $class = shift; + my $fh = do { local *HANDLE; \*HANDLE }; + return bless $fh, $class; +} +sub READ { } +sub READLINE { } +sub GETC { } + +1; diff --git a/cpan/Test-Harness/t/lib/EmptyParser.pm b/cpan/Test-Harness/t/lib/EmptyParser.pm new file mode 100644 index 0000000000..2f7ec2428e --- /dev/null +++ b/cpan/Test-Harness/t/lib/EmptyParser.pm @@ -0,0 +1,30 @@ +package EmptyParser; + +use strict; +use vars qw(@ISA); + +use TAP::Parser (); + +@ISA = qw(TAP::Parser); + +sub _initialize { + shift->_set_defaults; +} + +# this should really be in TAP::Parser itself... +sub _set_defaults { + my $self = shift; + + for my $key ( + qw( source_class perl_source_class grammar_class + iterator_factory_class result_factory_class ) + ) + { + my $default_method = "_default_$key"; + $self->$key( $self->$default_method() ); + } + + return $self; +} + +1; diff --git a/cpan/Test-Harness/t/lib/IO/c55Capture.pm b/cpan/Test-Harness/t/lib/IO/c55Capture.pm new file mode 100644 index 0000000000..ecbcb49ba7 --- /dev/null +++ b/cpan/Test-Harness/t/lib/IO/c55Capture.pm @@ -0,0 +1,120 @@ +package IO::c55Capture; + +use IO::Handle; + +=head1 Name + +t/lib/IO::c55Capture - a wafer-thin test support package + +=head1 Why!? + +Compatibility with 5.5.3 and no external dependencies. + +=head1 Usage + +Works with a global filehandle: + + # set a spool to write to + tie local *STDOUT, 'IO::c55Capture'; + ... + # clear and retrieve buffer list + my @spooled = tied(*STDOUT)->dump(); + +Or, a lexical (and autocreated) filehandle: + + my $capture = IO::c55Capture->new_handle; + ... + my @output = tied($$capture)->dump; + +Note the '$$' dereference. + +=cut + +# XXX actually returns an IO::Handle :-/ +sub new_handle { + my $class = shift; + my $handle = IO::Handle->new; + tie $$handle, $class; + return ($handle); +} + +sub TIEHANDLE { + return bless [], __PACKAGE__; +} + +sub PRINT { + my $self = shift; + + push @$self, @_; +} + +sub PRINTF { + my $self = shift; + push @$self, sprintf(@_); +} + +sub dump { + my $self = shift; + my @got = @$self; + @$self = (); + return @got; +} + +package util; + +use IO::File; + +# mostly stolen from Module::Build MBTest.pm + +{ # backwards compatible temp filename recipe adapted from perlfaq + my $tmp_count = 0; + my $tmp_base_name = sprintf( "%d-%d", $$, time() ); + + sub temp_file_name { + sprintf( "%s-%04d", $tmp_base_name, ++$tmp_count ); + } +} +######################################################################## + +sub save_handle { + my ( $handle, $subr ) = @_; + my $outfile = temp_file_name(); + + local *SAVEOUT; + open SAVEOUT, ">&" . fileno($handle) + or die "Can't save output handle: $!"; + open $handle, "> $outfile" or die "Can't create $outfile: $!"; + + eval { $subr->() }; + my $err = $@; + open $handle, ">&SAVEOUT" or die "Can't restore output: $!"; + + my $ret = slurp($outfile); + 1 while unlink $outfile; + $err and die $err; + return $ret; +} + +sub stdout_of { save_handle( \*STDOUT, @_ ) } +sub stderr_of { save_handle( \*STDERR, @_ ) } + +sub stdout_stderr_of { + my $subr = shift; + my ( $stdout, $stderr ); + $stdout = stdout_of( + sub { + $stderr = stderr_of($subr); + } + ); + return ( $stdout, $stderr ); +} + +sub slurp { + my $fh = IO::File->new( $_[0] ) or die "Can't open $_[0]: $!"; + local $/; + return scalar <$fh>; +} + +1; + +# vim:ts=4:sw=4:et:sta diff --git a/cpan/Test-Harness/t/lib/MyCustom.pm b/cpan/Test-Harness/t/lib/MyCustom.pm new file mode 100644 index 0000000000..2402312edc --- /dev/null +++ b/cpan/Test-Harness/t/lib/MyCustom.pm @@ -0,0 +1,12 @@ +# avoid cut-n-paste exhaustion with this mixin + +package MyCustom; +use strict; + +sub custom { + my $self = shift; + $main::CUSTOM{ ref($self) }++; + return $self; +} + +1; diff --git a/cpan/Test-Harness/t/lib/MyGrammar.pm b/cpan/Test-Harness/t/lib/MyGrammar.pm new file mode 100644 index 0000000000..ef93f9dfc1 --- /dev/null +++ b/cpan/Test-Harness/t/lib/MyGrammar.pm @@ -0,0 +1,21 @@ +# subclass for testing customizing & subclassing + +package MyGrammar; + +use strict; +use vars '@ISA'; + +use MyCustom; +use TAP::Parser::Grammar; + +@ISA = qw( TAP::Parser::Grammar MyCustom ); + +sub _initialize { + my $self = shift; + $self->SUPER::_initialize(@_); + $main::INIT{ ref($self) }++; + $self->{initialized} = 1; + return $self; +} + +1; diff --git a/cpan/Test-Harness/t/lib/MyIterator.pm b/cpan/Test-Harness/t/lib/MyIterator.pm new file mode 100644 index 0000000000..561f6e2c78 --- /dev/null +++ b/cpan/Test-Harness/t/lib/MyIterator.pm @@ -0,0 +1,26 @@ +# subclass for testing customizing & subclassing + +package MyIterator; + +use strict; +use vars '@ISA'; + +use MyCustom; +use TAP::Parser::Iterator; + +@ISA = qw( TAP::Parser::Iterator MyCustom ); + +sub _initialize { + my $self = shift; + $self->SUPER::_initialize(@_); + $main::INIT{ ref($self) }++; + $self->{initialized} = 1; + $self->{content} = [ 'whats TAP all about then?', '1..1', 'ok 1' ]; + return $self; +} + +sub next { + return shift @{ $_[0]->{content} }; +} + +1; diff --git a/cpan/Test-Harness/t/lib/MyIteratorFactory.pm b/cpan/Test-Harness/t/lib/MyIteratorFactory.pm new file mode 100644 index 0000000000..d8c3269cda --- /dev/null +++ b/cpan/Test-Harness/t/lib/MyIteratorFactory.pm @@ -0,0 +1,19 @@ +# subclass for testing customizing & subclassing + +package MyIteratorFactory; + +use strict; +use vars '@ISA'; + +use MyCustom; +use MyIterator; +use TAP::Parser::IteratorFactory; + +@ISA = qw( TAP::Parser::IteratorFactory MyCustom ); + +sub make_iterator { + my $class = shift; + return MyIterator->new(@_); +} + +1; diff --git a/cpan/Test-Harness/t/lib/MyPerlSource.pm b/cpan/Test-Harness/t/lib/MyPerlSource.pm new file mode 100644 index 0000000000..6193db97df --- /dev/null +++ b/cpan/Test-Harness/t/lib/MyPerlSource.pm @@ -0,0 +1,27 @@ +# subclass for testing customizing & subclassing + +package MyPerlSource; + +use strict; +use vars '@ISA'; + +use MyCustom; +use TAP::Parser::Source::Perl; + +@ISA = qw( TAP::Parser::Source::Perl MyCustom ); + +sub _initialize { + my $self = shift; + $self->SUPER::_initialize(@_); + $main::INIT{ ref($self) }++; + $self->{initialized} = 1; + return $self; +} + +sub source { + my $self = shift; + return $self->SUPER::source(@_); +} + +1; + diff --git a/cpan/Test-Harness/t/lib/MyResult.pm b/cpan/Test-Harness/t/lib/MyResult.pm new file mode 100644 index 0000000000..ab4845dedf --- /dev/null +++ b/cpan/Test-Harness/t/lib/MyResult.pm @@ -0,0 +1,21 @@ +# subclass for testing customizing & subclassing + +package MyResult; + +use strict; +use vars '@ISA'; + +use MyCustom; +use TAP::Parser::Result; + +@ISA = qw( TAP::Parser::Result MyCustom ); + +sub _initialize { + my $self = shift; + $self->SUPER::_initialize(@_); + $main::INIT{ ref($self) }++; + $self->{initialized} = 1; + return $self; +} + +1; diff --git a/cpan/Test-Harness/t/lib/MyResultFactory.pm b/cpan/Test-Harness/t/lib/MyResultFactory.pm new file mode 100644 index 0000000000..371bba632b --- /dev/null +++ b/cpan/Test-Harness/t/lib/MyResultFactory.pm @@ -0,0 +1,23 @@ +# subclass for testing customizing & subclassing + +package MyResultFactory; + +use strict; +use vars '@ISA'; + +use MyCustom; +use MyResult; +use TAP::Parser::ResultFactory; + +@ISA = qw( TAP::Parser::ResultFactory MyCustom ); + +sub make_result { + my $class = shift; + + # I know, this is not really being initialized, but + # for consistency's sake, deal with it :) + $main::INIT{$class}++; + return MyResult->new(@_); +} + +1; diff --git a/cpan/Test-Harness/t/lib/MySource.pm b/cpan/Test-Harness/t/lib/MySource.pm new file mode 100644 index 0000000000..5e41b829ae --- /dev/null +++ b/cpan/Test-Harness/t/lib/MySource.pm @@ -0,0 +1,34 @@ +# subclass for testing customizing & subclassing + +package MySource; + +use strict; +use vars '@ISA'; + +use MyCustom; +use TAP::Parser::Source; + +@ISA = qw( TAP::Parser::Source MyCustom ); + +sub _initialize { + my $self = shift; + $self->SUPER::_initialize(@_); + $main::INIT{ ref($self) }++; + $self->{initialized} = 1; + return $self; +} + +sub source { + my $self = shift; + return $self->SUPER::source(@_); +} + +sub get_stream { + my $self = shift; + my $stream = $self->SUPER::get_stream(@_); + + # re-bless it: + bless $stream, 'MyIterator'; +} + +1; diff --git a/cpan/Test-Harness/t/lib/NOP.pm b/cpan/Test-Harness/t/lib/NOP.pm new file mode 100644 index 0000000000..6de1dbfbd5 --- /dev/null +++ b/cpan/Test-Harness/t/lib/NOP.pm @@ -0,0 +1,7 @@ +package NOP; + +# Do nothing much + +sub new { bless {}, shift } + +1; diff --git a/cpan/Test-Harness/t/lib/NoFork.pm b/cpan/Test-Harness/t/lib/NoFork.pm new file mode 100644 index 0000000000..0225e9628d --- /dev/null +++ b/cpan/Test-Harness/t/lib/NoFork.pm @@ -0,0 +1,21 @@ +package NoFork; + +BEGIN { + *CORE::GLOBAL::fork = sub { die "you should not fork" }; +} +use Config; +tied(%Config)->{d_fork} = 0; # blatant lie + +=begin TEST + +Assuming not to much chdir: + + PERL5OPT='-It/lib -MNoFork' perl -Ilib bin/prove -r t + +=end TEST + +=cut + +1; + +# vim:ts=4:sw=4:et:sta diff --git a/cpan/Test-Harness/t/lib/TAP/Parser/SubclassTest.pm b/cpan/Test-Harness/t/lib/TAP/Parser/SubclassTest.pm new file mode 100644 index 0000000000..84becee932 --- /dev/null +++ b/cpan/Test-Harness/t/lib/TAP/Parser/SubclassTest.pm @@ -0,0 +1,39 @@ +# subclass for testing subclassing + +package TAP::Parser::SubclassTest; + +use strict; +use vars qw(@ISA); + +use TAP::Parser; + +use MyCustom; +use MySource; +use MyPerlSource; +use MyGrammar; +use MyIteratorFactory; +use MyResultFactory; + +@ISA = qw( TAP::Parser MyCustom ); + +sub _default_source_class {'MySource'} +sub _default_perl_source_class {'MyPerlSource'} +sub _default_grammar_class {'MyGrammar'} +sub _default_iterator_factory_class {'MyIteratorFactory'} +sub _default_result_factory_class {'MyResultFactory'} + +sub make_source { shift->SUPER::make_source(@_)->custom } +sub make_perl_source { shift->SUPER::make_perl_source(@_)->custom } +sub make_grammar { shift->SUPER::make_grammar(@_)->custom } +sub make_iterator { shift->SUPER::make_iterator(@_)->custom } +sub make_result { shift->SUPER::make_result(@_)->custom } + +sub _initialize { + my $self = shift; + $self->SUPER::_initialize(@_); + $main::INIT{ ref($self) }++; + $self->{initialized} = 1; + return $self; +} + +1; diff --git a/cpan/Test-Harness/t/multiplexer.t b/cpan/Test-Harness/t/multiplexer.t new file mode 100644 index 0000000000..649d5d161f --- /dev/null +++ b/cpan/Test-Harness/t/multiplexer.t @@ -0,0 +1,170 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; + +use Test::More qw( no_plan ); + +use File::Spec; +use TAP::Parser; +use TAP::Parser::Multiplexer; +use TAP::Parser::Iterator::Process; + +my $fork_desc + = TAP::Parser::Iterator::Process->_use_open3 + ? 'fork' + : 'nofork'; + +my @schedule = ( + { name => 'Single non-selectable source', + + # Returns a list of parser, stash pairs. The stash contains the + # TAP that we expect from this parser. + sources => sub { + my @tap = ( + '1..1', + 'ok 1 Just fine' + ); + + return [ + TAP::Parser->new( { tap => join( "\n", @tap ) . "\n" } ), + \@tap, + ]; + }, + }, + { name => 'Two non-selectable sources', + sources => sub { + my @tap = ( + [ '1..1', + 'ok 1 Just fine' + ], + [ '1..2', + 'not ok 1 Oh dear', + 'ok 2 Better' + ] + ); + + return map { + [ TAP::Parser->new( { tap => join( "\n", @$_ ) . "\n" } ), + $_ + ] + } @tap; + }, + }, + { name => 'Single selectable source', + sources => sub { + return [ + TAP::Parser->new( + { source => File::Spec->catfile( + 't', + 'sample-tests', + 'simple' + ), + } + ), + [ '1..5', + 'ok 1', + 'ok 2', + 'ok 3', + 'ok 4', + 'ok 5', + ] + ]; + }, + }, + { name => 'Three selectable sources', + sources => sub { + return map { + [ TAP::Parser->new( + { source => File::Spec->catfile( + 't', + 'sample-tests', + 'simple' + ), + } + ), + [ '1..5', + 'ok 1', + 'ok 2', + 'ok 3', + 'ok 4', + 'ok 5', + ] + ] + } 1 .. 3; + }, + }, + { name => 'Three selectable sources, two non-selectable sources', + sources => sub { + my @tap = ( + [ '1..1', + 'ok 1 Just fine' + ], + [ '1..2', + 'not ok 1 Oh dear', + 'ok 2 Better' + ] + ); + + return ( + map { + [ TAP::Parser->new( + { tap => join( "\n", @$_ ) . "\n" } + ), + $_ + ] + } @tap + ), + ( map { + [ TAP::Parser->new( + { source => File::Spec->catfile( + 't', + 'sample-tests', + 'simple' + ), + } + ), + [ '1..5', + 'ok 1', + 'ok 2', + 'ok 3', + 'ok 4', + 'ok 5', + ] + ] + } 1 .. 3 + ); + }, + } +); + +for my $test (@schedule) { + my $name = "$test->{name} ($fork_desc)"; + my @sources = $test->{sources}->(); + my $mux = TAP::Parser::Multiplexer->new; + + my $count = @sources; + $mux->add(@$_) for @sources; + + is $mux->parsers, $count, "$name: count OK"; + + while ( my ( $parser, $stash, $result ) = $mux->next ) { + + # use Data::Dumper; + # diag Dumper( { stash => $stash, result => $result } ); + if ( defined $result ) { + my $expect = ( shift @$stash ) || ' OOPS '; + my $got = $result->raw; + is $got, $expect, "$name: '$expect' OK"; + } + else { + ok @$stash == 0, "$name: EOF OK"; + + # Make sure we only get one EOF per stream + push @$stash, ' expect no more '; + } + } + is $mux->parsers, 0, "$name: All used up"; +} + +1; diff --git a/cpan/Test-Harness/t/nofork-mux.t b/cpan/Test-Harness/t/nofork-mux.t new file mode 100644 index 0000000000..4f28bf8c1d --- /dev/null +++ b/cpan/Test-Harness/t/nofork-mux.t @@ -0,0 +1,10 @@ +#!/usr/bin/perl -w + +BEGIN { + use lib 't/lib'; +} + +use strict; + +use NoFork; +require( 't/multiplexer.t' ); diff --git a/cpan/Test-Harness/t/nofork.t b/cpan/Test-Harness/t/nofork.t new file mode 100644 index 0000000000..1d8b340e1b --- /dev/null +++ b/cpan/Test-Harness/t/nofork.t @@ -0,0 +1,59 @@ +#!/usr/bin/perl -w + +# check nofork logic on systems which *can* fork() +# NOTE maybe a good candidate for xt/author or something. + +use lib 't/lib'; + +use strict; + +use Config; +use Test::More ( + $Config{d_fork} + ? 'no_plan' + : ( 'skip_all' => 'your system already has no fork' ) +); +use IO::c55Capture; # for util + +use TAP::Harness; + +sub backticks { + my (@args) = @_; + + util::stdout_of( sub { system(@args) and die "error $?" } ); +} + +my @libs = map "-I$_", @INC; +my @perl = ( $^X, @libs ); +my $mod = 'TAP::Parser::Iterator::Process'; + +{ # just check the introspective method to start... + my $code = qq(print $mod->_use_open3 ? 1 : 2); + { + my $ans = backticks( @perl, '-MNoFork', "-M$mod", '-e', $code ); + is( $ans, 2, 'says not to fork' ); + } + { + local $ENV{PERL5OPT}; # punt: prevent propogating -MNoFork + my $ans = backticks( @perl, "-M$mod", '-e', $code ); + is( $ans, 1, 'says to fork' ); + } +} + +{ # and make sure we can run a test + my $capture = IO::c55Capture->new_handle; + local *STDERR; + my $harness = TAP::Harness->new( + { verbosity => -2, + switches => [ @libs, "-MNoFork" ], + stdout => $capture, + } + ); + $harness->runtests( 't/sample-tests/simple' ); + my @output = tied($$capture)->dump; + is pop @output, "Result: PASS\n", 'status OK'; + pop @output; # get rid of summary line + is( $output[-1], "All tests successful.\n", 'ran with no fork' ); +} + +# vim:ts=4:sw=4:et:sta diff --git a/cpan/Test-Harness/t/object.t b/cpan/Test-Harness/t/object.t new file mode 100644 index 0000000000..b1a4dd0b98 --- /dev/null +++ b/cpan/Test-Harness/t/object.t @@ -0,0 +1,37 @@ +#!/usr/bin/perl -wT + +use strict; +use lib 't/lib'; + +use Test::More tests => 7; + +use_ok('TAP::Object'); + +can_ok( 'TAP::Object', 'new' ); +can_ok( 'TAP::Object', '_initialize' ); +can_ok( 'TAP::Object', '_croak' ); + +{ + + package TAP::TestObj; + use vars qw(@ISA); + @ISA = qw(TAP::Object); + + sub _initialize { + my $self = shift; + $self->{init} = 1; + $self->{args} = [@_]; + return $self; + } +} + +# I know these tests are simple, but they're documenting the base API, so +# necessary none-the-less... +my $obj = TAP::TestObj->new( 'foo', { bar => 'baz' } ); +ok( $obj->{init}, '_initialize' ); +is_deeply( $obj->{args}, [ 'foo', { bar => 'baz' } ], '_initialize: args' ); + +eval { $obj->_croak('eek') }; +my $err = $@; +like( $err, qr/^eek/, '_croak' ); + diff --git a/cpan/Test-Harness/t/parse.t b/cpan/Test-Harness/t/parse.t new file mode 100644 index 0000000000..f0def28c9a --- /dev/null +++ b/cpan/Test-Harness/t/parse.t @@ -0,0 +1,1058 @@ +#!/usr/bin/perl -w + +use strict; + +use lib 't/lib'; + +use Test::More tests => 294; +use IO::c55Capture; + +use File::Spec; + +use TAP::Parser; +use TAP::Parser::IteratorFactory; + +sub _get_results { + my $parser = shift; + my @results; + while ( defined( my $result = $parser->next ) ) { + push @results => $result; + } + return @results; +} + +my ( $PARSER, $PLAN, $PRAGMA, $TEST, $COMMENT, $BAILOUT, $UNKNOWN, $YAML, $VERSION ) = qw( + TAP::Parser + TAP::Parser::Result::Plan + TAP::Parser::Result::Pragma + TAP::Parser::Result::Test + TAP::Parser::Result::Comment + TAP::Parser::Result::Bailout + TAP::Parser::Result::Unknown + TAP::Parser::Result::YAML + TAP::Parser::Result::Version +); + +my $factory = TAP::Parser::IteratorFactory->new; + +my $tap = <<'END_TAP'; +TAP version 13 +1..7 +ok 1 - input file opened +... this is junk +not ok first line of the input valid # todo some data +# this is a comment +ok 3 - read the rest of the file +not ok 4 - this is a real failure + --- YAML! + ... +ok 5 # skip we have no description +ok 6 - you shall not pass! # TODO should have failed +not ok 7 - Gandalf wins. Game over. # TODO 'bout time! +END_TAP + +can_ok $PARSER, 'new'; +my $parser = $PARSER->new( { tap => $tap } ); +isa_ok $parser, $PARSER, '... and the object it returns'; + +ok $ENV{TAP_VERSION}, 'TAP_VERSION env variable should be set'; + +# results() is sane? + +my @results = _get_results($parser); +is scalar @results, 12, '... and there should be one for each line'; + +my $version = shift @results; +isa_ok $version, $VERSION; +is $version->version, '13', '... and the version should be 13'; + +# check the test plan + +my $result = shift @results; +isa_ok $result, $PLAN; +can_ok $result, 'type'; +is $result->type, 'plan', '... and it should report the correct type'; +ok $result->is_plan, '... and it should identify itself as a plan'; +is $result->plan, '1..7', '... and identify the plan'; +ok !$result->directive, '... and this plan should not have a directive'; +ok !$result->explanation, '... or a directive explanation'; +is $result->as_string, '1..7', + '... and have the correct string representation'; +is $result->raw, '1..7', '... and raw() should return the original line'; + +# a normal, passing test + +my $test = shift @results; +isa_ok $test, $TEST; +is $test->type, 'test', '... and it should report the correct type'; +ok $test->is_test, '... and it should identify itself as a test'; +is $test->ok, 'ok', '... and it should have the correct ok()'; +ok $test->is_ok, '... and the correct boolean version of is_ok()'; +ok $test->is_actual_ok, + '... and the correct boolean version of is_actual_ok()'; +is $test->number, 1, '... and have the correct test number'; +is $test->description, '- input file opened', + '... and the correct description'; +ok !$test->directive, '... and not have a directive'; +ok !$test->explanation, '... or a directive explanation'; +ok !$test->has_skip, '... and it is not a SKIPped test'; +ok !$test->has_todo, '... nor a TODO test'; +is $test->as_string, 'ok 1 - input file opened', + '... and its string representation should be correct'; +is $test->raw, 'ok 1 - input file opened', + '... and raw() should return the original line'; + +# junk lines should be preserved + +my $unknown = shift @results; +isa_ok $unknown, $UNKNOWN; +is $unknown->type, 'unknown', '... and it should report the correct type'; +ok $unknown->is_unknown, '... and it should identify itself as unknown'; +is $unknown->as_string, '... this is junk', + '... and its string representation should be returned verbatim'; +is $unknown->raw, '... this is junk', + '... and raw() should return the original line'; + +# a failing test, which also happens to have a directive + +my $failed = shift @results; +isa_ok $failed, $TEST; +is $failed->type, 'test', '... and it should report the correct type'; +ok $failed->is_test, '... and it should identify itself as a test'; +is $failed->ok, 'not ok', '... and it should have the correct ok()'; +ok $failed->is_ok, '... and TODO tests should always pass'; +ok !$failed->is_actual_ok, + '... and the correct boolean version of is_actual_ok ()'; +is $failed->number, 2, '... and have the correct failed number'; +is $failed->description, 'first line of the input valid', + '... and the correct description'; +is $failed->directive, 'TODO', '... and should have the correct directive'; +is $failed->explanation, 'some data', + '... and the correct directive explanation'; +ok !$failed->has_skip, '... and it is not a SKIPped failed'; +ok $failed->has_todo, '... but it is a TODO succeeded'; +is $failed->as_string, + 'not ok 2 first line of the input valid # TODO some data', + '... and its string representation should be correct'; +is $failed->raw, 'not ok first line of the input valid # todo some data', + '... and raw() should return the original line'; + +# comments + +my $comment = shift @results; +isa_ok $comment, $COMMENT; +is $comment->type, 'comment', '... and it should report the correct type'; +ok $comment->is_comment, '... and it should identify itself as a comment'; +is $comment->comment, 'this is a comment', + '... and you should be able to fetch the comment'; +is $comment->as_string, '# this is a comment', + '... and have the correct string representation'; +is $comment->raw, '# this is a comment', + '... and raw() should return the original line'; + +# another normal, passing test + +$test = shift @results; +isa_ok $test, $TEST; +is $test->type, 'test', '... and it should report the correct type'; +ok $test->is_test, '... and it should identify itself as a test'; +is $test->ok, 'ok', '... and it should have the correct ok()'; +ok $test->is_ok, '... and the correct boolean version of is_ok()'; +ok $test->is_actual_ok, + '... and the correct boolean version of is_actual_ok()'; +is $test->number, 3, '... and have the correct test number'; +is $test->description, '- read the rest of the file', + '... and the correct description'; +ok !$test->directive, '... and not have a directive'; +ok !$test->explanation, '... or a directive explanation'; +ok !$test->has_skip, '... and it is not a SKIPped test'; +ok !$test->has_todo, '... nor a TODO test'; +is $test->as_string, 'ok 3 - read the rest of the file', + '... and its string representation should be correct'; +is $test->raw, 'ok 3 - read the rest of the file', + '... and raw() should return the original line'; + +# a failing test + +$failed = shift @results; +isa_ok $failed, $TEST; +is $failed->type, 'test', '... and it should report the correct type'; +ok $failed->is_test, '... and it should identify itself as a test'; +is $failed->ok, 'not ok', '... and it should have the correct ok()'; +ok !$failed->is_ok, '... and the tests should not have passed'; +ok !$failed->is_actual_ok, + '... and the correct boolean version of is_actual_ok ()'; +is $failed->number, 4, '... and have the correct failed number'; +is $failed->description, '- this is a real failure', + '... and the correct description'; +ok !$failed->directive, '... and should have no directive'; +ok !$failed->explanation, '... and no directive explanation'; +ok !$failed->has_skip, '... and it is not a SKIPped failed'; +ok !$failed->has_todo, '... and not a TODO test'; +is $failed->as_string, 'not ok 4 - this is a real failure', + '... and its string representation should be correct'; +is $failed->raw, 'not ok 4 - this is a real failure', + '... and raw() should return the original line'; + +# Some YAML +my $yaml = shift @results; +isa_ok $yaml, $YAML; +is $yaml->type, 'yaml', '... and it should report the correct type'; +ok $yaml->is_yaml, '... and it should identify itself as yaml'; +is_deeply $yaml->data, 'YAML!', '... and data should be correct'; + +# ok 5 # skip we have no description +# skipped test + +$test = shift @results; +isa_ok $test, $TEST; +is $test->type, 'test', '... and it should report the correct type'; +ok $test->is_test, '... and it should identify itself as a test'; +is $test->ok, 'ok', '... and it should have the correct ok()'; +ok $test->is_ok, '... and the correct boolean version of is_ok()'; +ok $test->is_actual_ok, + '... and the correct boolean version of is_actual_ok()'; +is $test->number, 5, '... and have the correct test number'; +ok !$test->description, '... and skipped tests have no description'; +is $test->directive, 'SKIP', '... and the correct directive'; +is $test->explanation, 'we have no description', + '... but we should have an explanation'; +ok $test->has_skip, '... and it is a SKIPped test'; +ok !$test->has_todo, '... but not a TODO test'; +is $test->as_string, 'ok 5 # SKIP we have no description', + '... and its string representation should be correct'; +is $test->raw, 'ok 5 # skip we have no description', + '... and raw() should return the original line'; + +# a failing test, which also happens to have a directive +# ok 6 - you shall not pass! # TODO should have failed + +my $bonus = shift @results; +isa_ok $bonus, $TEST; +can_ok $bonus, 'todo_passed'; +is $bonus->type, 'test', 'TODO tests should parse correctly'; +ok $bonus->is_test, '... and it should identify itself as a test'; +is $bonus->ok, 'ok', '... and it should have the correct ok()'; +ok $bonus->is_ok, '... and TODO tests should not always pass'; +ok $bonus->is_actual_ok, + '... and the correct boolean version of is_actual_ok ()'; +is $bonus->number, 6, '... and have the correct failed number'; +is $bonus->description, '- you shall not pass!', + '... and the correct description'; +is $bonus->directive, 'TODO', '... and should have the correct directive'; +is $bonus->explanation, 'should have failed', + '... and the correct directive explanation'; +ok !$bonus->has_skip, '... and it is not a SKIPped failed'; +ok $bonus->has_todo, '... but it is a TODO succeeded'; +is $bonus->as_string, 'ok 6 - you shall not pass! # TODO should have failed', + '... and its string representation should be correct'; +is $bonus->raw, 'ok 6 - you shall not pass! # TODO should have failed', + '... and raw() should return the original line'; +ok $bonus->todo_passed, + '... todo_bonus() should pass for TODO tests which unexpectedly succeed'; + +# not ok 7 - Gandalf wins. Game over. # TODO 'bout time! + +my $passed = shift @results; +isa_ok $passed, $TEST; +can_ok $passed, 'todo_passed'; +is $passed->type, 'test', 'TODO tests should parse correctly'; +ok $passed->is_test, '... and it should identify itself as a test'; +is $passed->ok, 'not ok', '... and it should have the correct ok()'; +ok $passed->is_ok, '... and TODO tests should always pass'; +ok !$passed->is_actual_ok, + '... and the correct boolean version of is_actual_ok ()'; +is $passed->number, 7, '... and have the correct passed number'; +is $passed->description, '- Gandalf wins. Game over.', + '... and the correct description'; +is $passed->directive, 'TODO', '... and should have the correct directive'; +is $passed->explanation, "'bout time!", + '... and the correct directive explanation'; +ok !$passed->has_skip, '... and it is not a SKIPped passed'; +ok $passed->has_todo, '... but it is a TODO succeeded'; +is $passed->as_string, + "not ok 7 - Gandalf wins. Game over. # TODO 'bout time!", + '... and its string representation should be correct'; +is $passed->raw, "not ok 7 - Gandalf wins. Game over. # TODO 'bout time!", + '... and raw() should return the original line'; +ok !$passed->todo_passed, + '... todo_passed() should not pass for TODO tests which failed'; + +# test parse results + +can_ok $parser, 'passed'; +is $parser->passed, 6, + '... and we should have the correct number of passed tests'; +is_deeply [ $parser->passed ], [ 1, 2, 3, 5, 6, 7 ], + '... and get a list of the passed tests'; + +can_ok $parser, 'failed'; +is $parser->failed, 1, '... and the correct number of failed tests'; +is_deeply [ $parser->failed ], [4], '... and get a list of the failed tests'; + +can_ok $parser, 'actual_passed'; +is $parser->actual_passed, 4, + '... and we should have the correct number of actually passed tests'; +is_deeply [ $parser->actual_passed ], [ 1, 3, 5, 6 ], + '... and get a list of the actually passed tests'; + +can_ok $parser, 'actual_failed'; +is $parser->actual_failed, 3, + '... and the correct number of actually failed tests'; +is_deeply [ $parser->actual_failed ], [ 2, 4, 7 ], + '... or get a list of the actually failed tests'; + +can_ok $parser, 'todo'; +is $parser->todo, 3, + '... and we should have the correct number of TODO tests'; +is_deeply [ $parser->todo ], [ 2, 6, 7 ], + '... and get a list of the TODO tests'; + +can_ok $parser, 'skipped'; +is $parser->skipped, 1, + '... and we should have the correct number of skipped tests'; +is_deeply [ $parser->skipped ], [5], + '... and get a list of the skipped tests'; + +# check the plan + +can_ok $parser, 'plan'; +is $parser->plan, '1..7', '... and we should have the correct plan'; +is $parser->tests_planned, 7, '... and the correct number of tests'; + +# "Unexpectedly succeeded" +can_ok $parser, 'todo_passed'; +is scalar $parser->todo_passed, 1, + '... and it should report the number of tests which unexpectedly succeeded'; +is_deeply [ $parser->todo_passed ], [6], + '... or *which* tests unexpectedly succeeded'; + +# +# Bug report from Torsten Schoenfeld +# Makes sure parser can handle blank lines +# + +$tap = <<'END_TAP'; +1..2 +ok 1 - input file opened + + +ok 2 - read the rest of the file +END_TAP + +my $aref = [ split /\n/ => $tap ]; + +can_ok $PARSER, 'new'; +$parser = $PARSER->new( { stream => $factory->make_iterator($aref) } ); +isa_ok $parser, $PARSER, '... and calling it should succeed'; + +# results() is sane? + +ok @results = _get_results($parser), 'The parser should return results'; +is scalar @results, 5, '... and there should be one for each line'; + +# check the test plan + +$result = shift @results; +isa_ok $result, $PLAN; +can_ok $result, 'type'; +is $result->type, 'plan', '... and it should report the correct type'; +ok $result->is_plan, '... and it should identify itself as a plan'; +is $result->plan, '1..2', '... and identify the plan'; +is $result->as_string, '1..2', + '... and have the correct string representation'; +is $result->raw, '1..2', '... and raw() should return the original line'; + +# a normal, passing test + +$test = shift @results; +isa_ok $test, $TEST; +is $test->type, 'test', '... and it should report the correct type'; +ok $test->is_test, '... and it should identify itself as a test'; +is $test->ok, 'ok', '... and it should have the correct ok()'; +ok $test->is_ok, '... and the correct boolean version of is_ok()'; +ok $test->is_actual_ok, + '... and the correct boolean version of is_actual_ok()'; +is $test->number, 1, '... and have the correct test number'; +is $test->description, '- input file opened', + '... and the correct description'; +ok !$test->directive, '... and not have a directive'; +ok !$test->explanation, '... or a directive explanation'; +ok !$test->has_skip, '... and it is not a SKIPped test'; +ok !$test->has_todo, '... nor a TODO test'; +is $test->as_string, 'ok 1 - input file opened', + '... and its string representation should be correct'; +is $test->raw, 'ok 1 - input file opened', + '... and raw() should return the original line'; + +# junk lines should be preserved + +$unknown = shift @results; +isa_ok $unknown, $UNKNOWN; +is $unknown->type, 'unknown', '... and it should report the correct type'; +ok $unknown->is_unknown, '... and it should identify itself as unknown'; +is $unknown->as_string, '', + '... and its string representation should be returned verbatim'; +is $unknown->raw, '', '... and raw() should return the original line'; + +# ... and the second empty line + +$unknown = shift @results; +isa_ok $unknown, $UNKNOWN; +is $unknown->type, 'unknown', '... and it should report the correct type'; +ok $unknown->is_unknown, '... and it should identify itself as unknown'; +is $unknown->as_string, '', + '... and its string representation should be returned verbatim'; +is $unknown->raw, '', '... and raw() should return the original line'; + +# a passing test + +$test = shift @results; +isa_ok $test, $TEST; +is $test->type, 'test', '... and it should report the correct type'; +ok $test->is_test, '... and it should identify itself as a test'; +is $test->ok, 'ok', '... and it should have the correct ok()'; +ok $test->is_ok, '... and the correct boolean version of is_ok()'; +ok $test->is_actual_ok, + '... and the correct boolean version of is_actual_ok()'; +is $test->number, 2, '... and have the correct test number'; +is $test->description, '- read the rest of the file', + '... and the correct description'; +ok !$test->directive, '... and not have a directive'; +ok !$test->explanation, '... or a directive explanation'; +ok !$test->has_skip, '... and it is not a SKIPped test'; +ok !$test->has_todo, '... nor a TODO test'; +is $test->as_string, 'ok 2 - read the rest of the file', + '... and its string representation should be correct'; +is $test->raw, 'ok 2 - read the rest of the file', + '... and raw() should return the original line'; + +is scalar $parser->passed, 2, + 'Empty junk lines should not affect the correct number of tests passed'; + +# Check source => "tap content" +can_ok $PARSER, 'new'; +$parser = $PARSER->new( { source => "1..1\nok 1\n" } ); +isa_ok $parser, $PARSER, '... and calling it should succeed'; +ok @results = _get_results($parser), 'The parser should return results'; +is( scalar @results, 2, "Got two lines of TAP" ); + +# Check source => [array] +can_ok $PARSER, 'new'; +$parser = $PARSER->new( { source => [ "1..1", "ok 1" ] } ); +isa_ok $parser, $PARSER, '... and calling it should succeed'; +ok @results = _get_results($parser), 'The parser should return results'; +is( scalar @results, 2, "Got two lines of TAP" ); + +# Check source => $filehandle +can_ok $PARSER, 'new'; +open my $fh, 't/data/catme.1'; +$parser = $PARSER->new( { source => $fh } ); +isa_ok $parser, $PARSER, '... and calling it should succeed'; +ok @results = _get_results($parser), 'The parser should return results'; +is( scalar @results, 2, "Got two lines of TAP" ); + +{ + + # set a spool to write to + tie local *SPOOL, 'IO::c55Capture'; + + my $tap = <<'END_TAP'; +TAP version 13 +1..7 +ok 1 - input file opened +... this is junk +not ok first line of the input valid # todo some data +# this is a comment +ok 3 - read the rest of the file +not ok 4 - this is a real failure + --- YAML! + ... +ok 5 # skip we have no description +ok 6 - you shall not pass! # TODO should have failed +not ok 7 - Gandalf wins. Game over. # TODO 'bout time! +END_TAP + + { + my $parser = $PARSER->new( + { tap => $tap, + spool => \*SPOOL, + } + ); + + _get_results($parser); + + my @spooled = tied(*SPOOL)->dump(); + + is @spooled, 24, 'coverage testing for spool attribute of parser'; + is join( '', @spooled ), $tap, "spooled tap matches"; + } + + { + my $parser = $PARSER->new( + { tap => $tap, + spool => \*SPOOL, + } + ); + + $parser->callback( 'ALL', sub { } ); + + _get_results($parser); + + my @spooled = tied(*SPOOL)->dump(); + + is @spooled, 24, 'coverage testing for spool attribute of parser'; + is join( '', @spooled ), $tap, "spooled tap matches"; + } +} + +{ + + # _initialize coverage + + my $x = bless [], 'kjsfhkjsdhf'; + + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + $PARSER->new(); + }; + + is @die, 1, 'coverage testing for _initialize'; + + like pop @die, qr/PANIC:\s+could not determine stream at/, + '...and it failed as expected'; + + @die = (); + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + $PARSER->new( + { stream => 'stream', + tap => 'tap', + source => 'source', # only one of these is allowed + } + ); + }; + + is @die, 1, 'coverage testing for _initialize'; + + like pop @die, + qr/You may only choose one of 'exec', 'stream', 'tap' or 'source'/, + '...and it failed as expected'; +} + +{ + + # coverage of todo_failed + + my $tap = <<'END_TAP'; +TAP version 13 +1..7 +ok 1 - input file opened +... this is junk +not ok first line of the input valid # todo some data +# this is a comment +ok 3 - read the rest of the file +not ok 4 - this is a real failure + --- YAML! + ... +ok 5 # skip we have no description +ok 6 - you shall not pass! # TODO should have failed +not ok 7 - Gandalf wins. Game over. # TODO 'bout time! +END_TAP + + my $parser = $PARSER->new( { tap => $tap } ); + + _get_results($parser); + + my @warn; + + eval { + local $SIG{__WARN__} = sub { push @warn, @_ }; + + $parser->todo_failed; + }; + + is @warn, 1, 'coverage testing of todo_failed'; + + like pop @warn, + qr/"todo_failed" is deprecated. Please use "todo_passed". See the docs[.]/, + '..and failed as expected' +} + +{ + + # coverage testing for T::P::_initialize + + # coverage of the source argument paths + + # ref argument to source + + my $parser = TAP::Parser->new( { source => [ split /$/, $tap ] } ); + + isa_ok $parser, 'TAP::Parser'; + + isa_ok $parser->_stream, 'TAP::Parser::Iterator::Array'; + + # uncategorisable argument to source + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + $parser = TAP::Parser->new( { source => 'nosuchfile' } ); + }; + + is @die, 1, 'uncategorisable source'; + + like pop @die, qr/Cannot determine source for nosuchfile/, + '... and we died as expected'; +} + +{ + + # coverage test of perl source with switches + + my $parser = TAP::Parser->new( + { source => File::Spec->catfile( + 't', + 'sample-tests', + 'simple' + ), + } + ); + + isa_ok $parser, 'TAP::Parser'; + + isa_ok $parser->_stream, 'TAP::Parser::Iterator::Process'; + + # Workaround for Mac OS X problem wrt closing the iterator without + # reading from it. + $parser->next; +} + +{ + + # coverage testing for TAP::Parser::has_problems + + # we're going to need to test lots of fragments of tap + # to cover all the different boolean tests + + # currently covered are no problems and failed, so let's next test + # todo_passed + + my $tap = <<'END_TAP'; +TAP version 13 +1..2 +ok 1 - input file opened +ok 2 - Gandalf wins. Game over. # TODO 'bout time! +END_TAP + + my $parser = TAP::Parser->new( { tap => $tap } ); + + _get_results($parser); + + ok !$parser->failed, 'parser didnt fail'; + ok $parser->todo_passed, '... and todo_passed is true'; + + ok !$parser->has_problems, '... and has_problems is false'; + + # now parse_errors + + $tap = <<'END_TAP'; +TAP version 13 +1..2 +SMACK +END_TAP + + $parser = TAP::Parser->new( { tap => $tap } ); + + _get_results($parser); + + ok !$parser->failed, 'parser didnt fail'; + ok !$parser->todo_passed, '... and todo_passed is false'; + ok $parser->parse_errors, '... and parse_errors is true'; + + ok $parser->has_problems, '... and has_problems'; + + # Now wait and exit are hard to do in an OS platform-independent way, so + # we won't even bother + + $tap = <<'END_TAP'; +TAP version 13 +1..2 +ok 1 - input file opened +ok 2 - Gandalf wins +END_TAP + + $parser = TAP::Parser->new( { tap => $tap } ); + + _get_results($parser); + + $parser->wait(1); + + ok !$parser->failed, 'parser didnt fail'; + ok !$parser->todo_passed, '... and todo_passed is false'; + ok !$parser->parse_errors, '... and parse_errors is false'; + + ok $parser->wait, '... and wait is set'; + + ok $parser->has_problems, '... and has_problems'; + + # and use the same for exit + + $parser->wait(0); + $parser->exit(1); + + ok !$parser->failed, 'parser didnt fail'; + ok !$parser->todo_passed, '... and todo_passed is false'; + ok !$parser->parse_errors, '... and parse_errors is false'; + ok !$parser->wait, '... and wait is not set'; + + ok $parser->exit, '... and exit is set'; + + ok $parser->has_problems, '... and has_problems'; +} + +{ + + # coverage testing of the version states + + my $tap = <<'END_TAP'; +TAP version 12 +1..2 +ok 1 - input file opened +ok 2 - Gandalf wins +END_TAP + + my $parser = TAP::Parser->new( { tap => $tap } ); + + _get_results($parser); + + my @errors = $parser->parse_errors; + + is @errors, 1, 'test too low version number'; + + like pop @errors, + qr/Explicit TAP version must be at least 13. Got version 12/, + '... and trapped expected version error'; + + # now too high a version + $tap = <<'END_TAP'; +TAP version 14 +1..2 +ok 1 - input file opened +ok 2 - Gandalf wins +END_TAP + + $parser = TAP::Parser->new( { tap => $tap } ); + + _get_results($parser); + + @errors = $parser->parse_errors; + + is @errors, 1, 'test too high version number'; + + like pop @errors, + qr/TAP specified version 14 but we don't know about versions later than 13/, + '... and trapped expected version error'; +} + +{ + + # coverage testing of TAP version in the wrong place + + my $tap = <<'END_TAP'; +1..2 +ok 1 - input file opened +TAP version 12 +ok 2 - Gandalf wins +END_TAP + + my $parser = TAP::Parser->new( { tap => $tap } ); + + _get_results($parser); + + my @errors = $parser->parse_errors; + + is @errors, 1, 'test TAP version number in wrong place'; + + like pop @errors, + qr/If TAP version is present it must be the first line of output/, + '... and trapped expected version error'; + +} + +{ + + # we're going to bash the internals a bit (but using the API as + # much as possible) to force grammar->tokenise() to fail + + # firstly we'll create a stream that dies when its next_raw method is called + + package TAP::Parser::Iterator::Dies; + + use strict; + use vars qw(@ISA); + + @ISA = qw(TAP::Parser::Iterator); + + sub next_raw { + die 'this is the dying iterator'; + } + + # required as part of the TPI interface + sub exit { } + sub wait { } + + package main; + + # now build a standard parser + + my $tap = <<'END_TAP'; +1..2 +ok 1 - input file opened +ok 2 - Gandalf wins +END_TAP + + { + my $parser = TAP::Parser->new( { tap => $tap } ); + + # build a dying stream + my $stream = TAP::Parser::Iterator::Dies->new; + + # now replace the stream - we're forced to us an T::P intenal + # method for this + $parser->_stream($stream); + + # build a new grammar + my $grammar = TAP::Parser::Grammar->new( + { stream => $stream, + parser => $parser + } + ); + + # replace our grammar with this new one + $parser->_grammar($grammar); + + # now call next on the parser, and the grammar should die + my $result = $parser->next; # will die in iterator + + is $result, undef, 'iterator dies'; + + my @errors = $parser->parse_errors; + is @errors, 2, '...and caught expected errrors'; + + like shift @errors, qr/this is the dying iterator/, + '...and it was what we expected'; + } + + # Do it all again with callbacks to exercise the other code path in + # the unrolled iterator + { + my $parser = TAP::Parser->new( { tap => $tap } ); + + $parser->callback( 'ALL', sub { } ); + + # build a dying stream + my $stream = TAP::Parser::Iterator::Dies->new; + + # now replace the stream - we're forced to us an T::P intenal + # method for this + $parser->_stream($stream); + + # build a new grammar + my $grammar = TAP::Parser::Grammar->new( + { stream => $stream, + parser => $parser + } + ); + + # replace our grammar with this new one + $parser->_grammar($grammar); + + # now call next on the parser, and the grammar should die + my $result = $parser->next; # will die in iterator + + is $result, undef, 'iterator dies'; + + my @errors = $parser->parse_errors; + is @errors, 2, '...and caught expected errrors'; + + like shift @errors, qr/this is the dying iterator/, + '...and it was what we expected'; + } +} + +{ + + # coverage testing of TAP::Parser::_next_state + + package TAP::Parser::WithBrokenState; + use vars qw(@ISA); + + @ISA = qw( TAP::Parser ); + + sub _make_state_table { + return { INIT => { plan => { goto => 'FOO' } } }; + } + + package main; + + my $tap = <<'END_TAP'; +1..2 +ok 1 - input file opened +ok 2 - Gandalf wins +END_TAP + + my $parser = TAP::Parser::WithBrokenState->new( { tap => $tap } ); + + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + $parser->next; + $parser->next; + }; + + is @die, 1, 'detect broken state machine'; + + like pop @die, qr/Illegal state: FOO/, + '...and the message is as we expect'; +} + +{ + + # coverage testing of TAP::Parser::_iter + + package TAP::Parser::WithBrokenIter; + use vars qw(@ISA); + + @ISA = qw( TAP::Parser ); + + sub _iter {return} + + package main; + + my $tap = <<'END_TAP'; +1..2 +ok 1 - input file opened +ok 2 - Gandalf wins +END_TAP + + my $parser = TAP::Parser::WithBrokenIter->new( { tap => $tap } ); + + my @die; + + eval { + local $SIG{__WARN__} = sub { }; + local $SIG{__DIE__} = sub { push @die, @_ }; + + $parser->next; + }; + + is @die, 1, 'detect broken iter'; + + like pop @die, qr/Can't use/, '...and the message is as we expect'; +} + +SKIP: { + + # http://markmail.org/message/rkxbo6ft7yorgnzb + skip "Crashes on older Perls", 2 if $] <= 5.008004 || $] == 5.009; + + # coverage testing of TAP::Parser::_finish + + my $tap = <<'END_TAP'; +1..2 +ok 1 - input file opened +ok 2 - Gandalf wins +END_TAP + + my $parser = TAP::Parser->new( { tap => $tap } ); + + $parser->tests_run(999); + + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + _get_results $parser; + }; + + is @die, 1, 'detect broken test counts'; + + like pop @die, + qr/Panic: planned test count [(]1001[)] did not equal sum of passed [(]0[)] and failed [(]2[)] tests!/, + '...and the message is as we expect'; +} + +{ + + # Sanity check on state table + + my $parser = TAP::Parser->new( { tap => "1..1\nok 1\n" } ); + my $state_table = $parser->_make_state_table; + my @states = sort keys %$state_table; + my @expect = sort qw( + bailout comment plan pragma test unknown version yaml + ); + + my %reachable = ( INIT => 1 ); + + for my $name (@states) { + my $state = $state_table->{$name}; + my @can_handle = sort keys %$state; + is_deeply \@can_handle, \@expect, "token types handled in $name"; + for my $type (@can_handle) { + $reachable{$_}++ + for grep {defined} + map { $state->{$type}->{$_} } qw(goto continue); + } + } + + is_deeply [ sort keys %reachable ], [@states], "all states reachable"; +} + +{ + + # exit, wait, ignore_exit interactions + + my @truth = ( + [ 0, 0, 0, 0 ], + [ 0, 0, 1, 0 ], + [ 1, 0, 0, 1 ], + [ 1, 0, 1, 0 ], + [ 1, 1, 0, 1 ], + [ 1, 1, 1, 0 ], + [ 0, 1, 0, 1 ], + [ 0, 1, 1, 0 ], + ); + + for my $t (@truth) { + my ( $wait, $exit, $ignore_exit, $has_problems ) = @$t; + my $test_parser = sub { + my $parser = shift; + $parser->wait($wait); + $parser->exit($exit); + ok $has_problems ? $parser->has_problems : !$parser->has_problems, + "exit=$exit, wait=$wait, ignore=$ignore_exit"; + }; + + my $parser = TAP::Parser->new( { tap => "1..1\nok 1\n" } ); + $parser->ignore_exit($ignore_exit); + $test_parser->($parser); + + $test_parser->( + TAP::Parser->new( + { tap => "1..1\nok 1\n", ignore_exit => $ignore_exit } + ) + ); + } +} diff --git a/cpan/Test-Harness/t/parser-config.t b/cpan/Test-Harness/t/parser-config.t new file mode 100644 index 0000000000..bd3625902d --- /dev/null +++ b/cpan/Test-Harness/t/parser-config.t @@ -0,0 +1,39 @@ +#!/usr/bin/perl -w + +BEGIN { + unshift @INC, 't/lib'; +} + +use strict; +use vars qw(%INIT %CUSTOM); + +use Test::More tests => 11; +use File::Spec::Functions qw( catfile updir ); +use TAP::Parser; + +use_ok('MySource'); +use_ok('MyPerlSource'); +use_ok('MyGrammar'); +use_ok('MyIteratorFactory'); +use_ok('MyResultFactory'); + +my $source = catfile( 't', 'source_tests', 'source' ); +my %customize = ( + source_class => 'MySource', + perl_source_class => 'MyPerlSource', + grammar_class => 'MyGrammar', + iterator_factory_class => 'MyIteratorFactory', + result_factory_class => 'MyResultFactory', +); +my $p = TAP::Parser->new( + { source => $source, + %customize, + } +); +ok( $p, 'new customized parser' ); + +foreach my $key ( keys %customize ) { + is( $p->$key(), $customize{$key}, "customized $key" ); +} + +# TODO: make sure these things are propogated down through the parser... diff --git a/cpan/Test-Harness/t/parser-subclass.t b/cpan/Test-Harness/t/parser-subclass.t new file mode 100644 index 0000000000..303c28ca27 --- /dev/null +++ b/cpan/Test-Harness/t/parser-subclass.t @@ -0,0 +1,80 @@ +#!/usr/bin/perl -w + +BEGIN { + unshift @INC, 't/lib'; +} + +use strict; +use vars qw(%INIT %CUSTOM); + +use Test::More tests => 24; +use File::Spec::Functions qw( catfile updir ); + +use_ok('TAP::Parser::SubclassTest'); + +# TODO: foreach my $source ( ... ) +{ # perl source + %INIT = %CUSTOM = (); + my $source = catfile( 't', 'subclass_tests', 'perl_source' ); + my $p = TAP::Parser::SubclassTest->new( { source => $source } ); + + # The grammar is lazily constructed so we need to ask for it to + # trigger it's creation. + my $grammer = $p->_grammar; + + ok( $p->{initialized}, 'new subclassed parser' ); + + is( $p->source_class => 'MySource', 'source_class' ); + is( $p->perl_source_class => 'MyPerlSource', 'perl_source_class' ); + is( $p->grammar_class => 'MyGrammar', 'grammar_class' ); + is( $p->iterator_factory_class => 'MyIteratorFactory', + 'iterator_factory_class' + ); + is( $p->result_factory_class => 'MyResultFactory', + 'result_factory_class' + ); + + is( $INIT{MyPerlSource}, 1, 'initialized MyPerlSource' ); + is( $CUSTOM{MyPerlSource}, 1, '... and it was customized' ); + is( $INIT{MyGrammar}, 1, 'initialized MyGrammar' ); + is( $CUSTOM{MyGrammar}, 1, '... and it was customized' ); + + # make sure overrided make_* methods work... + %CUSTOM = (); + $p->make_source; + is( $CUSTOM{MySource}, 1, 'make custom source' ); + $p->make_perl_source; + is( $CUSTOM{MyPerlSource}, 1, 'make custom perl source' ); + $p->make_grammar; + is( $CUSTOM{MyGrammar}, 1, 'make custom grammar' ); + $p->make_iterator; + is( $CUSTOM{MyIterator}, 1, 'make custom iterator' ); + $p->make_result; + is( $CUSTOM{MyResult}, 1, 'make custom result' ); + + # make sure parser helpers use overrided classes too (the parser should + # be the central source of configuration/overriding functionality) + # The source is already tested above (parser doesn't keep a copy of the + # source currently). So only one to check is the Grammar: + %INIT = %CUSTOM = (); + my $r = $p->_grammar->tokenize; + isa_ok( $r, 'MyResult', 'i has results' ); + is( $INIT{MyResult}, 1, 'initialized MyResult' ); + is( $CUSTOM{MyResult}, 1, '... and it was customized' ); + is( $INIT{MyResultFactory}, 1, '"initialized" MyResultFactory' ); +} + +SKIP: { # non-perl source + %INIT = %CUSTOM = (); + my $cat = '/bin/cat'; + unless ( -e $cat ) { + skip "no '$cat'", 4; + } + my $file = catfile( 't', 'data', 'catme.1' ); + my $p = TAP::Parser::SubclassTest->new( { exec => [ $cat => $file ] } ); + + is( $INIT{MySource}, 1, 'initialized MySource subclass' ); + is( $CUSTOM{MySource}, 1, '... and it was customized' ); + is( $INIT{MyIterator}, 1, 'initialized MyIterator subclass' ); + is( $CUSTOM{MyIterator}, 1, '... and it was customized' ); +} diff --git a/cpan/Test-Harness/t/perl5lib.t b/cpan/Test-Harness/t/perl5lib.t new file mode 100644 index 0000000000..51113e156b --- /dev/null +++ b/cpan/Test-Harness/t/perl5lib.t @@ -0,0 +1,51 @@ +#!/usr/bin/perl -w + +# Test that PERL5LIB is propogated from the harness process to the test +# process. + +use strict; +use lib 't/lib'; +use Config; + +my $path_sep = $Config{path_sep}; + +sub has_crazy_patch { + my $sentinel = 'blirpzoffle'; + local $ENV{PERL5LIB} = $sentinel; + my $command = join ' ', + map {qq{"$_"}} ( $^X, '-e', 'print join q(:), @INC' ); + my $path = `$command`; + my @got = ( $path =~ /($sentinel)/g ); + return @got > 1; +} + +use Test::More ( + $^O eq 'VMS' ? ( skip_all => 'VMS' ) + : has_crazy_patch() ? ( skip_all => 'Incompatible @INC patch' ) + : ( tests => 1 ) +); + +use Test::Harness; +use App::Prove; + +# Change PERL5LIB so we ensure it's preserved. +$ENV{PERL5LIB} = join( + $path_sep, 'wibble', + ( $ENV{PERL_CORE} ? '../lib' : () ), $ENV{PERL5LIB} || '' +); + +open TEST, ">perl5lib_check.t.tmp"; +print TEST <<"END"; +#!/usr/bin/perl +use strict; +use Test::More tests => 1; +like \$ENV{PERL5LIB}, qr/(^|${path_sep})wibble${path_sep}/; +END +close TEST; + +END { 1 while unlink 'perl5lib_check.t.tmp'; } + +my $h = TAP::Harness->new( { lib => ['something'], verbosity => -3 } ); +ok( !$h->runtests('perl5lib_check.t.tmp')->has_errors ); + +1; diff --git a/cpan/Test-Harness/t/premature-bailout.t b/cpan/Test-Harness/t/premature-bailout.t new file mode 100644 index 0000000000..9226a44064 --- /dev/null +++ b/cpan/Test-Harness/t/premature-bailout.t @@ -0,0 +1,125 @@ +#!/usr/bin/perl -wT + +use strict; +use lib 't/lib'; + +use Test::More tests => 14; + +use TAP::Parser; +use TAP::Parser::IteratorFactory; + +sub tap_to_lines { + my $string = shift; + my @lines = ( $string =~ /.*\n/g ); + return \@lines; +} + +my $tap = <<'END_TAP'; +1..4 +ok 1 - input file opened +... this is junk +not ok first line of the input valid # todo some data +# this is a comment +ok 3 - read the rest of the file +not ok 4 - this is a real failure +Bail out! We ran out of foobar. +not ok 5 +END_TAP + +my $factory = TAP::Parser::IteratorFactory->new; +my $parser = TAP::Parser->new( + { stream => $factory->make_iterator( tap_to_lines($tap) ), + } +); + +# results() is sane? + +# check the test plan +my $result = $parser->next(); + +# TEST +ok $result->is_plan, 'We should have a plan'; + +# a normal, passing test + +my $test = $parser->next(); + +# TEST +ok $test->is_test, '... and a test'; + +# junk lines should be preserved + +my $unknown = $parser->next(); + +# TEST +ok $unknown->is_unknown, '... and an unknown line'; + +# a failing test, which also happens to have a directive + +my $failed = $parser->next(); + +# TEST +ok $failed->is_test, '... and another test'; + +# comments + +my $comment = $parser->next(); + +# TEST +ok $comment->is_comment, '... and a comment'; + +# another normal, passing test + +$test = $parser->next(); + +# TEST +ok $test->is_test, '... and another test'; + +# a failing test + +$failed = $parser->next(); + +# TEST +ok $failed->is_test, '... and yet another test'; + +# ok 5 # skip we have no description +# skipped test +my $bailout = $parser->next(); + +# TEST +ok $bailout->is_bailout, 'And finally we should have a bailout'; + +# TEST +is $bailout->as_string, 'We ran out of foobar.', + '... and as_string() should return the explanation'; + +# TEST +is( $bailout->raw, 'Bail out! We ran out of foobar.', + '... and raw() should return the explanation' +); + +# TEST +is( $bailout->explanation, 'We ran out of foobar.', + '... and it should have the correct explanation' +); + +my $more_tap = "1..1\nok 1 - input file opened\n"; + +my $second_parser = TAP::Parser->new( + { stream => $factory->make_iterator( [ split( /\n/, $more_tap ) ] ), + } +); + +$result = $second_parser->next(); + +# TEST +ok $result->is_plan(), "Result is not the leftover line"; + +$result = $second_parser->next(); + +# TEST +ok $result->is_test(), "Result is a test"; + +# TEST +ok $result->is_ok(), "The event has passed"; + diff --git a/cpan/Test-Harness/t/process.t b/cpan/Test-Harness/t/process.t new file mode 100644 index 0000000000..5135d67f95 --- /dev/null +++ b/cpan/Test-Harness/t/process.t @@ -0,0 +1,53 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; + +my $hires; + +BEGIN { + $hires = eval 'use Time::HiRes qw(sleep); 1'; +} + +use Test::More ( + $^O eq 'VMS' ? ( skip_all => 'VMS' ) + : $hires ? ( tests => 9 * 3 ) + : ( skip_all => 'Need Time::HiRes' ) +); + +use File::Spec; +use TAP::Parser::Iterator::Process; + +my @expect = ( + '1..5', + 'ok 1 00000', + 'ok 2', + 'not ok 3', + 'ok 4', + 'ok 5 00000', +); + +my $source = File::Spec->catfile( + 't', + 'sample-tests', + 'delayed' +); + +for my $chunk_size ( 1, 4, 65536 ) { + for my $where ( 0 .. 8 ) { + + my $proc = TAP::Parser::Iterator::Process->new( + { _chunk_size => $chunk_size, + command => [ $^X, $source, ( 1 << $where ) ] + } + ); + + my @got = (); + while ( defined( my $line = $proc->next_raw ) ) { + push @got, $line; + } + + is_deeply \@got, \@expect, + "I/O ok with delay at position $where, chunk size $chunk_size"; + } +} diff --git a/cpan/Test-Harness/t/prove.t b/cpan/Test-Harness/t/prove.t new file mode 100644 index 0000000000..71730cdbf6 --- /dev/null +++ b/cpan/Test-Harness/t/prove.t @@ -0,0 +1,1525 @@ +#!/usr/bin/perl -w + +BEGIN { + unshift @INC, 't/lib'; +} + +use strict; + +use Test::More; +use File::Spec; + +use App::Prove; + +package FakeProve; +use vars qw( @ISA ); + +@ISA = qw( App::Prove ); + +sub new { + my $class = shift; + my $self = $class->SUPER::new(@_); + $self->{_log} = []; + return $self; +} + +sub _color_default {0} + +sub _runtests { + my $self = shift; + push @{ $self->{_log} }, [ '_runtests', @_ ]; +} + +sub get_log { + my $self = shift; + my @log = @{ $self->{_log} }; + $self->{_log} = []; + return @log; +} + +sub _shuffle { + my $self = shift; + s/^/xxx/ for @_; +} + +package main; + +sub mabs { + my $ar = shift; + return [ map { File::Spec->rel2abs($_) } @$ar ]; +} + +{ + my @import_log = (); + sub test_log_import { push @import_log, [@_] } + + sub get_import_log { + my @log = @import_log; + @import_log = (); + return @log; + } + + my @plugin_load_log = (); + sub test_log_plugin_load { push @plugin_load_log, [@_] } + + sub get_plugin_load_log { + my @log = @plugin_load_log; + @plugin_load_log = (); + return @log; + } +} + +my ( @ATTR, %DEFAULT_ASSERTION, @SCHEDULE ); + +# see the "ACTUAL TEST" section at the bottom + +BEGIN { # START PLAN + + # list of attributes + @ATTR = qw( + archive argv blib color directives exec extension failures + formatter harness includes lib merge parse quiet really_quiet + recurse backwards shuffle taint_fail taint_warn verbose + warnings_fail warnings_warn + ); + + # what we expect if the 'expect' hash does not define it + %DEFAULT_ASSERTION = map { $_ => undef } @ATTR; + + $DEFAULT_ASSERTION{includes} = $DEFAULT_ASSERTION{argv} + = sub { 'ARRAY' eq ref shift }; + + my @dummy_tests = map { File::Spec->catdir( 't', 'sample-tests', $_ ) } + qw(simple simple_yaml); + my $dummy_test = $dummy_tests[0]; + + ######################################################################## + # declarations - this drives all of the subtests. + # The cheatsheet follows. + # required: name, expect + # optional: + # args - arguments to constructor + # switches - command-line switches + # runlog - expected results of internal calls to _runtests, must + # match FakeProve's _log attr + # run_error - depends on 'runlog' (if missing, asserts no error) + # extra - follow-up check to handle exceptional cleanup / verification + # class - The App::Prove subclass to test. Defaults to FakeProve + @SCHEDULE = ( + { name => 'Create empty', + expect => {} + }, + { name => 'Set all options via constructor', + args => { + archive => 1, + argv => [qw(one two three)], + blib => 2, + color => 3, + directives => 4, + exec => 5, + failures => 7, + formatter => 8, + harness => 9, + includes => [qw(four five six)], + lib => 10, + merge => 11, + parse => 13, + quiet => 14, + really_quiet => 15, + recurse => 16, + backwards => 17, + shuffle => 18, + taint_fail => 19, + taint_warn => 20, + verbose => 21, + warnings_fail => 22, + warnings_warn => 23, + }, + expect => { + archive => 1, + argv => [qw(one two three)], + blib => 2, + color => 3, + directives => 4, + exec => 5, + failures => 7, + formatter => 8, + harness => 9, + includes => [qw(four five six)], + lib => 10, + merge => 11, + parse => 13, + quiet => 14, + really_quiet => 15, + recurse => 16, + backwards => 17, + shuffle => 18, + taint_fail => 19, + taint_warn => 20, + verbose => 21, + warnings_fail => 22, + warnings_warn => 23, + } + }, + { name => 'Call with defaults', + args => { argv => [qw( one two three )] }, + expect => {}, + runlog => [ + [ '_runtests', + { verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + + # Test all options individually + + # { name => 'Just archive', + # args => { + # argv => [qw( one two three )], + # archive => 1, + # }, + # expect => { + # archive => 1, + # }, + # runlog => [ + # [ { archive => 1, + # }, + # 'TAP::Harness', + # 'one', 'two', + # 'three' + # ] + # ], + # }, + { name => 'Just argv', + args => { + argv => [qw( one two three )], + }, + expect => { + argv => [qw( one two three )], + }, + runlog => [ + [ '_runtests', + { verbosity => 0, show_count => 1 }, + 'TAP::Harness', + 'one', 'two', + 'three' + ] + ], + }, + { name => 'Just blib', + args => { + argv => [qw( one two three )], + blib => 1, + }, + expect => { + blib => 1, + }, + runlog => [ + [ '_runtests', + { lib => mabs( [ 'blib/lib', 'blib/arch' ] ), + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + + { name => 'Just color', + args => { + argv => [qw( one two three )], + color => 1, + }, + expect => { + color => 1, + }, + runlog => [ + [ '_runtests', + { color => 1, + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + + { name => 'Just directives', + args => { + argv => [qw( one two three )], + directives => 1, + }, + expect => { + directives => 1, + }, + runlog => [ + [ '_runtests', + { directives => 1, + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just exec', + args => { + argv => [qw( one two three )], + exec => 1, + }, + expect => { + exec => 1, + }, + runlog => [ + [ '_runtests', + { exec => [1], + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just failures', + args => { + argv => [qw( one two three )], + failures => 1, + }, + expect => { + failures => 1, + }, + runlog => [ + [ '_runtests', + { failures => 1, + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + + { name => 'Just formatter', + args => { + argv => [qw( one two three )], + formatter => 'TAP::Harness', + }, + expect => { + formatter => 'TAP::Harness', + }, + runlog => [ + [ '_runtests', + { formatter_class => 'TAP::Harness', + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + + { name => 'Just includes', + args => { + argv => [qw( one two three )], + includes => [qw( four five six )], + }, + expect => { + includes => [qw( four five six )], + }, + runlog => [ + [ '_runtests', + { lib => mabs( [qw( four five six )] ), + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just lib', + args => { + argv => [qw( one two three )], + lib => 1, + }, + expect => { + lib => 1, + }, + runlog => [ + [ '_runtests', + { lib => mabs( ['lib'] ), + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just merge', + args => { + argv => [qw( one two three )], + merge => 1, + }, + expect => { + merge => 1, + }, + runlog => [ + [ '_runtests', + { merge => 1, + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just parse', + args => { + argv => [qw( one two three )], + parse => 1, + }, + expect => { + parse => 1, + }, + runlog => [ + [ '_runtests', + { errors => 1, + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just quiet', + args => { + argv => [qw( one two three )], + quiet => 1, + }, + expect => { + quiet => 1, + }, + runlog => [ + [ '_runtests', + { verbosity => -1, + show_count => 1, + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just really_quiet', + args => { + argv => [qw( one two three )], + really_quiet => 1, + }, + expect => { + really_quiet => 1, + }, + runlog => [ + [ '_runtests', + { verbosity => -2, + show_count => 1, + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just recurse', + args => { + argv => [qw( one two three )], + recurse => 1, + }, + expect => { + recurse => 1, + }, + runlog => [ + [ '_runtests', + { verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just reverse', + args => { + argv => [qw( one two three )], + backwards => 1, + }, + expect => { + backwards => 1, + }, + runlog => [ + [ '_runtests', + { verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + 'three', 'two', 'one' + ] + ], + }, + + { name => 'Just shuffle', + args => { + argv => [qw( one two three )], + shuffle => 1, + }, + expect => { + shuffle => 1, + }, + runlog => [ + [ '_runtests', + { verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + 'xxxone', 'xxxtwo', + 'xxxthree' + ] + ], + }, + { name => 'Just taint_fail', + args => { + argv => [qw( one two three )], + taint_fail => 1, + }, + expect => { + taint_fail => 1, + }, + runlog => [ + [ '_runtests', + { switches => ['-T'], + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just taint_warn', + args => { + argv => [qw( one two three )], + taint_warn => 1, + }, + expect => { + taint_warn => 1, + }, + runlog => [ + [ '_runtests', + { switches => ['-t'], + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just verbose', + args => { + argv => [qw( one two three )], + verbose => 1, + }, + expect => { + verbose => 1, + }, + runlog => [ + [ '_runtests', + { verbosity => 1, + show_count => 1, + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just warnings_fail', + args => { + argv => [qw( one two three )], + warnings_fail => 1, + }, + expect => { + warnings_fail => 1, + }, + runlog => [ + [ '_runtests', + { switches => ['-W'], + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + { name => 'Just warnings_warn', + args => { + argv => [qw( one two three )], + warnings_warn => 1, + }, + expect => { + warnings_warn => 1, + }, + runlog => [ + [ '_runtests', + { switches => ['-w'], + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + 'one', 'two', 'three' + ] + ], + }, + + # Command line parsing + { name => 'Switch -v', + args => { + argv => [qw( one two three )], + }, + switches => [ '-v', $dummy_test ], + expect => { + verbose => 1, + }, + runlog => [ + [ '_runtests', + { verbosity => 1, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch --verbose', + args => { + argv => [qw( one two three )], + }, + switches => [ '--verbose', $dummy_test ], + expect => { + verbose => 1, + }, + runlog => [ + [ '_runtests', + { verbosity => 1, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch -f', + args => { + argv => [qw( one two three )], + }, + switches => [ '-f', $dummy_test ], + expect => { failures => 1 }, + runlog => [ + [ '_runtests', + { failures => 1, + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch --failures', + args => { + argv => [qw( one two three )], + }, + switches => [ '--failures', $dummy_test ], + expect => { failures => 1 }, + runlog => [ + [ '_runtests', + { failures => 1, + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch -l', + args => { + argv => [qw( one two three )], + }, + switches => [ '-l', $dummy_test ], + expect => { lib => 1 }, + runlog => [ + [ '_runtests', + { lib => mabs( ['lib'] ), + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch --lib', + args => { + argv => [qw( one two three )], + }, + switches => [ '--lib', $dummy_test ], + expect => { lib => 1 }, + runlog => [ + [ '_runtests', + { lib => mabs( ['lib'] ), + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch -b', + args => { + argv => [qw( one two three )], + }, + switches => [ '-b', $dummy_test ], + expect => { blib => 1 }, + runlog => [ + [ '_runtests', + { lib => mabs( [ 'blib/lib', 'blib/arch' ] ), + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch --blib', + args => { + argv => [qw( one two three )], + }, + switches => [ '--blib', $dummy_test ], + expect => { blib => 1 }, + runlog => [ + [ '_runtests', + { lib => mabs( [ 'blib/lib', 'blib/arch' ] ), + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch -s', + args => { + argv => [qw( one two three )], + }, + switches => [ '-s', $dummy_test ], + expect => { shuffle => 1 }, + runlog => [ + [ '_runtests', + { verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + "xxx$dummy_test" + ] + ], + }, + + { name => 'Switch --shuffle', + args => { + argv => [qw( one two three )], + }, + switches => [ '--shuffle', $dummy_test ], + expect => { shuffle => 1 }, + runlog => [ + [ '_runtests', + { verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + "xxx$dummy_test" + ] + ], + }, + + { name => 'Switch -c', + args => { + argv => [qw( one two three )], + }, + switches => [ '-c', $dummy_test ], + expect => { color => 1 }, + runlog => [ + [ '_runtests', + { color => 1, + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch -r', + args => { + argv => [qw( one two three )], + }, + switches => [ '-r', $dummy_test ], + expect => { recurse => 1 }, + runlog => [ + [ '_runtests', + { verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch --recurse', + args => { + argv => [qw( one two three )], + }, + switches => [ '--recurse', $dummy_test ], + expect => { recurse => 1 }, + runlog => [ + [ '_runtests', + { verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch --reverse', + args => { + argv => [qw( one two three )], + }, + switches => [ '--reverse', @dummy_tests ], + expect => { backwards => 1 }, + runlog => [ + [ '_runtests', + { verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + reverse @dummy_tests + ] + ], + }, + + { name => 'Switch -p', + args => { + argv => [qw( one two three )], + }, + switches => [ '-p', $dummy_test ], + expect => { + parse => 1, + }, + runlog => [ + [ '_runtests', + { errors => 1, + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch --parse', + args => { + argv => [qw( one two three )], + }, + switches => [ '--parse', $dummy_test ], + expect => { + parse => 1, + }, + runlog => [ + [ '_runtests', + { errors => 1, + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch -q', + args => { + argv => [qw( one two three )], + }, + switches => [ '-q', $dummy_test ], + expect => { quiet => 1 }, + runlog => [ + [ '_runtests', + { verbosity => -1, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch --quiet', + args => { + argv => [qw( one two three )], + }, + switches => [ '--quiet', $dummy_test ], + expect => { quiet => 1 }, + runlog => [ + [ '_runtests', + { verbosity => -1, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch -Q', + args => { + argv => [qw( one two three )], + }, + switches => [ '-Q', $dummy_test ], + expect => { really_quiet => 1 }, + runlog => [ + [ '_runtests', + { verbosity => -2, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch --QUIET', + args => { + argv => [qw( one two three )], + }, + switches => [ '--QUIET', $dummy_test ], + expect => { really_quiet => 1 }, + runlog => [ + [ '_runtests', + { verbosity => -2, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch -m', + args => { + argv => [qw( one two three )], + }, + switches => [ '-m', $dummy_test ], + expect => { merge => 1 }, + runlog => [ + [ '_runtests', + { merge => 1, + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch --merge', + args => { + argv => [qw( one two three )], + }, + switches => [ '--merge', $dummy_test ], + expect => { merge => 1 }, + runlog => [ + [ '_runtests', + { merge => 1, + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Switch --directives', + args => { + argv => [qw( one two three )], + }, + switches => [ '--directives', $dummy_test ], + expect => { directives => 1 }, + runlog => [ + [ '_runtests', + { directives => 1, + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + # .proverc + { name => 'Empty exec in .proverc', + args => { + argv => [qw( one two three )], + }, + proverc => 't/proverc/emptyexec', + switches => [$dummy_test], + expect => { exec => '' }, + runlog => [ + [ '_runtests', + { exec => [], + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + # Executing one word (why would it be a -s though?) + { name => 'Switch --exec -s', + args => { + argv => [qw( one two three )], + }, + switches => [ '--exec', '-s', $dummy_test ], + expect => { exec => '-s' }, + runlog => [ + [ '_runtests', + { exec => ['-s'], + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + # multi-part exec + { name => 'Switch --exec "/foo/bar/perl -Ilib"', + args => { + argv => [qw( one two three )], + }, + switches => [ '--exec', '/foo/bar/perl -Ilib', $dummy_test ], + expect => { exec => '/foo/bar/perl -Ilib' }, + runlog => [ + [ '_runtests', + { exec => [qw(/foo/bar/perl -Ilib)], + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + # null exec (run tests as compiled binaries) + { name => 'Switch --exec ""', + switches => [ '--exec', '', $dummy_test ], + expect => { + exec => # ick, must workaround the || default bit with a sub + sub { my $val = shift; defined($val) and !length($val) } + }, + runlog => [ + [ '_runtests', + { exec => [], + verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + # Plugins + { name => 'Load plugin', + switches => [ '-P', 'Dummy', $dummy_test ], + args => { + argv => [qw( one two three )], + }, + expect => { + plugins => ['Dummy'], + }, + extra => sub { + my @loaded = get_import_log(); + is_deeply \@loaded, [ ['App::Prove::Plugin::Dummy'] ], + "Plugin loaded OK"; + }, + plan => 1, + runlog => [ + [ '_runtests', + { verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Load plugin (args)', + switches => [ '-P', 'Dummy=cracking,cheese,gromit', $dummy_test ], + args => { + argv => [qw( one two three )], + }, + expect => { + plugins => ['Dummy'], + }, + extra => sub { + my @loaded = get_import_log(); + is_deeply \@loaded, + [ [ 'App::Prove::Plugin::Dummy', 'cracking', 'cheese', + 'gromit' + ] + ], + "Plugin loaded OK"; + }, + plan => 1, + runlog => [ + [ '_runtests', + { verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Load plugin (explicit path)', + switches => [ '-P', 'App::Prove::Plugin::Dummy', $dummy_test ], + args => { + argv => [qw( one two three )], + }, + expect => { + plugins => ['Dummy'], + }, + extra => sub { + my @loaded = get_import_log(); + is_deeply \@loaded, [ ['App::Prove::Plugin::Dummy'] ], + "Plugin loaded OK"; + }, + plan => 1, + runlog => [ + [ '_runtests', + { verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Load plugin (args + call load method)', + switches => [ '-P', 'Dummy2=fou,du,fafa', $dummy_test ], + args => { + argv => [qw( one two three )], + }, + expect => { + plugins => ['Dummy2'], + }, + extra => sub { + my @import = get_import_log(); + is_deeply \@import, + [ [ 'App::Prove::Plugin::Dummy2', 'fou', 'du', 'fafa' ] ], + "Plugin loaded OK"; + + my @loaded = get_plugin_load_log(); + is( scalar @loaded, 1, 'Plugin->load called OK' ); + my ( $plugin_class, $args ) = @{ shift @loaded }; + is( $plugin_class, 'App::Prove::Plugin::Dummy2', + 'plugin_class passed' + ); + isa_ok( + $args->{app_prove}, 'App::Prove', + 'app_prove object passed' + ); + is_deeply( + $args->{args}, [qw( fou du fafa )], + 'expected args passed' + ); + }, + plan => 5, + runlog => [ + [ '_runtests', + { verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + { name => 'Load module', + switches => [ '-M', 'App::Prove::Plugin::Dummy', $dummy_test ], + args => { + argv => [qw( one two three )], + }, + expect => { + plugins => ['Dummy'], + }, + extra => sub { + my @loaded = get_import_log(); + is_deeply \@loaded, [ ['App::Prove::Plugin::Dummy'] ], + "Plugin loaded OK"; + }, + plan => 1, + runlog => [ + [ '_runtests', + { verbosity => 0, + show_count => 1, + }, + 'TAP::Harness', + $dummy_test + ] + ], + }, + + # TODO + # Hmm, that doesn't work... + # { name => 'Switch -h', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '-h', $dummy_test ], + # expect => {}, + # runlog => [ + # [ '_runtests', + # {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + + # { name => 'Switch --help', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '--help', $dummy_test ], + # expect => {}, + # runlog => [ + # [ {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + # { name => 'Switch -?', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '-?', $dummy_test ], + # expect => {}, + # runlog => [ + # [ {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + # + # { name => 'Switch -H', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '-H', $dummy_test ], + # expect => {}, + # runlog => [ + # [ {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + # + # { name => 'Switch --man', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '--man', $dummy_test ], + # expect => {}, + # runlog => [ + # [ {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + # + # { name => 'Switch -V', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '-V', $dummy_test ], + # expect => {}, + # runlog => [ + # [ {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + # + # { name => 'Switch --version', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '--version', $dummy_test ], + # expect => {}, + # runlog => [ + # [ {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + # + # { name => 'Switch --color!', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '--color!', $dummy_test ], + # expect => {}, + # runlog => [ + # [ {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + # + { name => 'Switch -I=s@', + args => { + argv => [qw( one two three )], + }, + switches => [ '-Ilib', $dummy_test ], + expect => { + includes => sub { + my ( $val, $attr ) = @_; + return + 'ARRAY' eq ref $val + && 1 == @$val + && $val->[0] =~ /lib$/; + }, + }, + }, + + # { name => 'Switch -a', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '-a', $dummy_test ], + # expect => {}, + # runlog => [ + # [ {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + # + # { name => 'Switch --archive=-s', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '--archive=-s', $dummy_test ], + # expect => {}, + # runlog => [ + # [ {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + # + # { name => 'Switch --formatter=-s', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '--formatter=-s', $dummy_test ], + # expect => {}, + # runlog => [ + # [ {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + # + # { name => 'Switch -e', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '-e', $dummy_test ], + # expect => {}, + # runlog => [ + # [ {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + # + # { name => 'Switch --harness=-s', + # args => { + # argv => [qw( one two three )], + # }, + # switches => [ '--harness=-s', $dummy_test ], + # expect => {}, + # runlog => [ + # [ {}, + # 'TAP::Harness', + # $dummy_test + # ] + # ], + # }, + + ); + + # END SCHEDULE + ######################################################################## + + my $extra_plan = 0; + for my $test (@SCHEDULE) { + $extra_plan += $test->{plan} || 0; + $extra_plan += 2 if $test->{runlog}; + $extra_plan += 1 if $test->{switches}; + } + + plan tests => @SCHEDULE * ( 3 + @ATTR ) + $extra_plan; +} # END PLAN + +# ACTUAL TEST +for my $test (@SCHEDULE) { + my $name = $test->{name}; + my $class = $test->{class} || 'FakeProve'; + + local $ENV{HARNESS_TIMER}; + + ok my $app = $class->new( exists $test->{args} ? $test->{args} : () ), + "$name: App::Prove created OK"; + + isa_ok $app, 'App::Prove'; + isa_ok $app, $class; + + # Optionally parse command args + if ( my $switches = $test->{switches} ) { + if ( my $proverc = $test->{proverc} ) { + $app->add_rc_file( File::Spec->catfile( split /\//, $proverc ) ); + } + eval { $app->process_args( '--norc', @$switches ) }; + if ( my $err_pattern = $test->{parse_error} ) { + like $@, $err_pattern, "$name: expected parse error"; + } + else { + ok !$@, "$name: no parse error"; + } + } + + my $expect = $test->{expect} || {}; + for my $attr ( sort @ATTR ) { + my $val = $app->$attr(); + my $assertion + = exists $expect->{$attr} + ? $expect->{$attr} + : $DEFAULT_ASSERTION{$attr}; + my $is_ok = undef; + + if ( 'CODE' eq ref $assertion ) { + $is_ok = ok $assertion->( $val, $attr ), + "$name: $attr has the expected value"; + } + elsif ( 'Regexp' eq ref $assertion ) { + $is_ok = like $val, $assertion, "$name: $attr matches $assertion"; + } + else { + $is_ok = is_deeply $val, $assertion, + "$name: $attr has the expected value"; + } + + unless ($is_ok) { + diag "got $val for $attr"; + } + } + + if ( my $runlog = $test->{runlog} ) { + eval { $app->run }; + if ( my $err_pattern = $test->{run_error} ) { + like $@, $err_pattern, "$name: expected error OK"; + pass; + pass for 1 .. $test->{plan}; + } + else { + unless ( ok !$@, "$name: no error OK" ) { + diag "$name: error: $@\n"; + } + + my $gotlog = [ $app->get_log ]; + + if ( my $extra = $test->{extra} ) { + $extra->($gotlog); + } + + unless ( + is_deeply $gotlog, $runlog, + "$name: run results match" + ) + { + use Data::Dumper; + diag Dumper( { wanted => $runlog, got => $gotlog } ); + } + } + } +} diff --git a/cpan/Test-Harness/t/proveenv.t b/cpan/Test-Harness/t/proveenv.t new file mode 100644 index 0000000000..be9942a043 --- /dev/null +++ b/cpan/Test-Harness/t/proveenv.t @@ -0,0 +1,17 @@ +#!perl +use strict; +use lib 't/lib'; +use Test::More tests => 2; +use App::Prove; + +{ + local $ENV{HARNESS_TIMER} = 0; + my $prv = App::Prove->new; + ok !$prv->timer, 'timer set via HARNESS_TIMER'; +} + +{ + local $ENV{HARNESS_TIMER} = 1; + my $prv = App::Prove->new; + ok $prv->timer, 'timer set via HARNESS_TIMER'; +} diff --git a/cpan/Test-Harness/t/proverc.t b/cpan/Test-Harness/t/proverc.t new file mode 100644 index 0000000000..37d6de803b --- /dev/null +++ b/cpan/Test-Harness/t/proverc.t @@ -0,0 +1,23 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use Test::More tests => 1; +use File::Spec; +use App::Prove; + +my $prove = App::Prove->new; + +$prove->add_rc_file( + File::Spec->catfile( + 't', 'data', + 'proverc' + ) +); + +is_deeply $prove->{rc_opts}, + [ '--should', 'be', '--split', 'correctly', 'Can', 'quote things', + 'using single or', 'double quotes', '--this', 'is', 'OK?' + ], + 'options parsed'; + diff --git a/cpan/Test-Harness/t/proverc/emptyexec b/cpan/Test-Harness/t/proverc/emptyexec new file mode 100644 index 0000000000..5381b8f015 --- /dev/null +++ b/cpan/Test-Harness/t/proverc/emptyexec @@ -0,0 +1,2 @@ +--exec '' + diff --git a/cpan/Test-Harness/t/proverun.t b/cpan/Test-Harness/t/proverun.t new file mode 100644 index 0000000000..6e6c2f33f5 --- /dev/null +++ b/cpan/Test-Harness/t/proverun.t @@ -0,0 +1,176 @@ +#!/usr/bin/perl -w + +BEGIN { + unshift @INC, 't/lib'; +} + +use strict; +use Test::More; +use File::Spec; +use App::Prove; + +my @SCHEDULE; + +BEGIN { + + # to add a new test to proverun, just list the name of the file in + # t/sample-tests and a name for the test. The rest is handled + # automatically. + my @tests = ( + { file => 'simple', + name => 'Create empty', + }, + { file => 'todo_inline', + name => 'Passing TODO', + }, + ); + foreach my $test (@tests) { + + # let's fully expand that filename + $test->{file} = File::Spec->catfile( + 't', + 'sample-tests', + $test->{file} + ); + } + @SCHEDULE = ( + map { + { name => $_->{name}, + args => [ $_->{file} ], + expect => [ + [ 'new', + 'TAP::Parser::Iterator::Process', + { merge => undef, + command => [ + 'PERL', + $_->{file}, + ], + setup => \'CODE', + teardown => \'CODE', + + } + ] + ] + } + } @tests + ); + + plan tests => @SCHEDULE * 3; +} + +# Waaaaay too much boilerplate + +package FakeProve; +use vars qw( @ISA ); + +@ISA = qw( App::Prove ); + +sub new { + my $class = shift; + my $self = $class->SUPER::new(@_); + $self->{_log} = []; + return $self; +} + +sub get_log { + my $self = shift; + my @log = @{ $self->{_log} }; + $self->{_log} = []; + return @log; +} + +package main; + +{ + use TAP::Parser::Iterator::Process; + use TAP::Formatter::Console; + + # Patch TAP::Parser::Iterator::Process + my @call_log = (); + + local $^W; # no warnings + + my $orig_new = TAP::Parser::Iterator::Process->can('new'); + + # Avoid "used only once" warning + *TAP::Parser::Iterator::Process::new + = *TAP::Parser::Iterator::Process::new = sub { + push @call_log, [ 'new', @_ ]; + + # And then new turns round and tramples on our args... + $_[1] = { %{ $_[1] } }; + $orig_new->(@_); + }; + + # Patch TAP::Formatter::Console; + my $orig_output = \&TAP::Formatter::Console::_output; + *TAP::Formatter::Console::_output = sub { + + # push @call_log, [ '_output', @_ ]; + }; + + sub get_log { + my @log = @call_log; + @call_log = (); + return @log; + } +} + +sub _slacken { + my $obj = shift; + if ( my $ref = ref $obj ) { + if ( 'HASH' eq ref $obj ) { + return { map { $_ => _slacken( $obj->{$_} ) } keys %$obj }; + } + elsif ( 'ARRAY' eq ref $obj ) { + return [ map { _slacken($_) } @$obj ]; + } + elsif ( 'SCALAR' eq ref $obj ) { + return $obj; + } + else { + return \$ref; + } + } + else { + return $obj; + } +} + +sub is_slackly($$$) { + my ( $got, $want, $msg ) = @_; + return is_deeply _slacken($got), _slacken($want), $msg; +} + +# ACTUAL TEST +for my $test (@SCHEDULE) { + my $name = $test->{name}; + + my $app = FakeProve->new; + $app->process_args( '--norc', @{ $test->{args} } ); + + # Why does this make the output from the test spew out of + # our STDOUT? + ok eval { $app->run }, 'run returned true'; + ok !$@, 'no errors' or diag $@; + + my @log = get_log(); + + # Bodge: we don't know what pathname will be used for the exe so we + # obliterate it here. Need to test that it's sane. + for my $call (@log) { + if ( 'HASH' eq ref $call->[2] && exists $call->[2]->{command} ) { + $call->[2]->{command}->[0] = 'PERL'; + } + } + + is_slackly \@log, $test->{expect}, "$name: command args OK"; + + # use Data::Dumper; + # diag Dumper( + # { got => \@log, + # expect => $test->{expect} + # } + # ); +} + diff --git a/cpan/Test-Harness/t/regression.t b/cpan/Test-Harness/t/regression.t new file mode 100644 index 0000000000..20879ca2b6 --- /dev/null +++ b/cpan/Test-Harness/t/regression.t @@ -0,0 +1,3264 @@ +#!/usr/bin/perl -w + +BEGIN { + push @INC, 't/lib'; +} + +use strict; + +use Test::More 'no_plan'; + +use File::Spec; +use Config; + +use constant TRUE => "__TRUE__"; +use constant FALSE => "__FALSE__"; + +# if wait() is non-zero, we cannot reliably predict its value +use constant NOT_ZERO => "__NOT_ZERO__"; + +use TAP::Parser; + +my $IsVMS = $^O eq 'VMS'; +my $IsWin32 = $^O eq 'MSWin32'; + +my $SAMPLE_TESTS = File::Spec->catdir( + File::Spec->curdir, + 't', + 'sample-tests' +); + +my %deprecated = map { $_ => 1 } qw( + TAP::Parser::good_plan + TAP::Parser::Result::Plan::passed + TAP::Parser::Result::Test::passed + TAP::Parser::Result::Test::actual_passed + TAP::Parser::Result::passed +); +$SIG{__WARN__} = sub { + if ( $_[0] =~ /is deprecated/ ) { + my @caller = caller(1); + my $sub = $caller[3]; + ok exists $deprecated{$sub}, + "... we should get a deprecated warning for $sub"; + } + else { + CORE::warn @_; + } +}; + +# the %samples keys are the names of test scripts in t/sample-tests +my %samples = ( + descriptive => { + results => [ + { is_plan => TRUE, + raw => '1..5', + tests_planned => 5, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + description => "Interlock activated", + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "Megathrusters are go", + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "Head formed", + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "Blazing sword formed", + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "Robeast destroyed", + is_unplanned => FALSE, + } + ], + plan => '1..5', + passed => [ 1 .. 5 ], + actual_passed => [ 1 .. 5 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + descriptive_trailing => { + results => [ + { actual_passed => TRUE, + is_actual_ok => TRUE, + description => "Interlock activated", + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "Megathrusters are go", + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "Head formed", + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "Blazing sword formed", + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "Robeast destroyed", + is_unplanned => FALSE, + }, + { is_plan => TRUE, + raw => '1..5', + tests_planned => 5, + passed => TRUE, + is_ok => TRUE, + }, + ], + plan => '1..5', + passed => [ 1 .. 5 ], + actual_passed => [ 1 .. 5 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + empty => { + results => [], + plan => '', + passed => [], + actual_passed => [], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => FALSE, + is_good_plan => FALSE, + tests_planned => undef, + tests_run => 0, + parse_errors => ['No plan found in TAP output'], + 'exit' => 0, + wait => 0, + version => 12, + }, + simple => { + results => [ + { is_plan => TRUE, + raw => '1..5', + tests_planned => 5, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + }, + ], + plan => '1..5', + passed => [ 1 .. 5 ], + actual_passed => [ 1 .. 5 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + space_after_plan => { + results => [ + { is_plan => TRUE, + raw => '1..5 ', + tests_planned => 5, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + }, + ], + plan => '1..5', + passed => [ 1 .. 5 ], + actual_passed => [ 1 .. 5 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + simple_yaml => { + results => [ + { is_version => TRUE, + raw => 'TAP version 13', + }, + { is_plan => TRUE, + raw => '1..5', + tests_planned => 5, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "", + }, + { is_yaml => TRUE, + data => [ + { 'fnurk' => 'skib', 'ponk' => 'gleeb' }, + { 'bar' => 'krup', 'foo' => 'plink' } + ], + raw => + " ---\n -\n fnurk: skib\n ponk: gleeb\n -\n bar: krup\n foo: plink\n ...", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + }, + { is_yaml => TRUE, + data => { + 'got' => [ '1', 'pong', '4' ], + 'expected' => [ '1', '2', '4' ] + }, + raw => + " ---\n expected:\n - 1\n - 2\n - 4\n got:\n - 1\n - pong\n - 4\n ...", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + }, + ], + plan => '1..5', + passed => [ 1 .. 5 ], + actual_passed => [ 1 .. 5 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 13, + }, + simple_fail => { + results => [ + { is_plan => TRUE, + raw => '1..5', + tests_planned => 5, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => "", + }, + { actual_passed => FALSE, + is_actual_ok => FALSE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + }, + { actual_passed => FALSE, + is_actual_ok => FALSE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + }, + ], + plan => '1..5', + passed => [ 1, 3, 4 ], + actual_passed => [ 1, 3, 4 ], + failed => [ 2, 5 ], + actual_failed => [ 2, 5 ], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + skip => { + results => [ + { is_plan => TRUE, + raw => '1..5', + tests_planned => 5, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => TRUE, + has_todo => FALSE, + number => 2, + description => "", + explanation => 'rain delay', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + }, + ], + plan => '1..5', + passed => [ 1 .. 5 ], + actual_passed => [ 1 .. 5 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [2], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + skip_nomsg => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..1', + tests_planned => 1, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => TRUE, + has_todo => FALSE, + number => 1, + description => "", + explanation => '', + }, + ], + plan => '1..1', + passed => [1], + actual_passed => [1], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [1], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 1, + tests_run => TRUE, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + todo_inline => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..3', + tests_planned => 3, + }, + { actual_passed => FALSE, + is_actual_ok => FALSE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => TRUE, + number => 1, + description => "- Foo", + explanation => 'Just testing the todo interface.', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => TRUE, + number => 2, + description => "- Unexpected success", + explanation => 'Just testing the todo interface.', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "- This is not todo", + explanation => '', + }, + ], + plan => '1..3', + passed => [ 1, 2, 3 ], + actual_passed => [ 2, 3 ], + failed => [], + actual_failed => [1], + todo => [ 1, 2 ], + todo_passed => [2], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 3, + tests_run => 3, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + todo => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..5 todo 3 2;', + tests_planned => 5, + todo_list => [ 3, 2 ], + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => "", + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => TRUE, + number => 2, + description => "", + explanation => '', + }, + { actual_passed => FALSE, + is_actual_ok => FALSE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => TRUE, + number => 3, + description => "", + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + explanation => '', + }, + ], + plan => '1..5', + passed => [ 1, 2, 3, 4, 5 ], + actual_passed => [ 1, 2, 4, 5 ], + failed => [], + actual_failed => [3], + todo => [ 2, 3 ], + todo_passed => [2], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + duplicates => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..10', + tests_planned => 10, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => '', + explanation => '', + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => '', + explanation => '', + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => '', + explanation => '', + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => '', + explanation => '', + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => '', + explanation => '', + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => '', + explanation => '', + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 6, + description => '', + explanation => '', + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 7, + description => '', + explanation => '', + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 8, + description => '', + explanation => '', + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 9, + description => '', + explanation => '', + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 10, + description => '', + explanation => '', + is_unplanned => TRUE, + }, + ], + plan => '1..10', + passed => [ 1 .. 4, 4 .. 9 ], + actual_passed => [ 1 .. 4, 4 .. 10 ], + failed => [10], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => FALSE, + tests_planned => 10, + tests_run => 11, + parse_errors => [ + 'Tests out of sequence. Found (4) but expected (5)', + 'Tests out of sequence. Found (5) but expected (6)', + 'Tests out of sequence. Found (6) but expected (7)', + 'Tests out of sequence. Found (7) but expected (8)', + 'Tests out of sequence. Found (8) but expected (9)', + 'Tests out of sequence. Found (9) but expected (10)', + 'Tests out of sequence. Found (10) but expected (11)', + 'Bad plan. You planned 10 tests but ran 11.', + ], + 'exit' => 0, + wait => 0, + }, + no_nums => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..5', + tests_planned => 5, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + description => "", + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "", + }, + { actual_passed => FALSE, + is_actual_ok => FALSE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + } + ], + plan => '1..5', + passed => [ 1, 2, 4, 5 ], + actual_passed => [ 1, 2, 4, 5 ], + failed => [3], + actual_failed => [3], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + bailout => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..5', + tests_planned => 5, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + description => "", + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "", + }, + { is_bailout => TRUE, + explanation => "GERONIMMMOOOOOO!!!", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + } + ], + plan => '1..5', + passed => [ 1 .. 5 ], + actual_passed => [ 1 .. 5 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + no_output => { + results => [], + plan => '', + passed => [], + actual_passed => [], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => FALSE, + tests_planned => undef, + tests_run => 0, + parse_errors => [ 'No plan found in TAP output', ], + 'exit' => 0, + wait => 0, + }, + too_many => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..3', + tests_planned => 3, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + description => "", + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "", + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "", + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + is_unplanned => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + is_unplanned => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 6, + description => "", + is_unplanned => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 7, + description => "", + is_unplanned => TRUE, + }, + ], + plan => '1..3', + passed => [ 1 .. 3 ], + actual_passed => [ 1 .. 7 ], + failed => [ 4 .. 7 ], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => FALSE, + tests_planned => 3, + tests_run => 7, + parse_errors => ['Bad plan. You planned 3 tests but ran 7.'], + 'exit' => 4, + wait => NOT_ZERO, + skip_if => sub {$IsVMS}, + }, + taint => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..1', + tests_planned => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + description => "- -T honored", + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + }, + ], + plan => '1..1', + passed => [ 1 .. 1 ], + actual_passed => [ 1 .. 1 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => TRUE, + tests_run => TRUE, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + 'die' => { + results => [], + plan => '', + passed => [], + actual_passed => [], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => FALSE, + tests_planned => undef, + tests_run => 0, + parse_errors => [ 'No plan found in TAP output', ], + 'exit' => NOT_ZERO, + wait => NOT_ZERO, + }, + die_head_end => { + results => [ + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => '', + explanation => '', + }, + ], + plan => '', + passed => [ 1 .. 4 ], + actual_passed => [ 1 .. 4 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => FALSE, + tests_planned => undef, + tests_run => 4, + parse_errors => [ 'No plan found in TAP output', ], + 'exit' => NOT_ZERO, + wait => NOT_ZERO, + }, + die_last_minute => { + results => [ + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => '', + explanation => '', + }, + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..4', + tests_planned => 4, + }, + ], + plan => '1..4', + passed => [ 1 .. 4 ], + actual_passed => [ 1 .. 4 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 4, + tests_run => 4, + parse_errors => [], + 'exit' => NOT_ZERO, + wait => NOT_ZERO, + }, + bignum => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..2', + tests_planned => 2, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 136211425, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 136211426, + description => '', + explanation => '', + }, + ], + plan => '1..2', + passed => [ 1, 2 ], + actual_passed => [ 1, 2, 136211425, 136211426 ], + failed => [ 136211425, 136211426 ], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => FALSE, + tests_planned => 2, + tests_run => 4, + parse_errors => [ + 'Tests out of sequence. Found (136211425) but expected (3)', + 'Tests out of sequence. Found (136211426) but expected (4)', + 'Bad plan. You planned 2 tests but ran 4.' + ], + 'exit' => 0, + wait => 0, + }, + bignum_many => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..2', + tests_planned => 2, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 99997, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 99998, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 99999, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 100000, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 100001, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 100002, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 100003, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 100004, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 100005, + description => '', + explanation => '', + }, + ], + plan => '1..2', + passed => [ 1, 2 ], + actual_passed => [ 1, 2, 99997 .. 100005 ], + failed => [ 99997 .. 100005 ], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => FALSE, + tests_planned => 2, + tests_run => 11, + parse_errors => [ + 'Tests out of sequence. Found (99997) but expected (3)', + 'Tests out of sequence. Found (99998) but expected (4)', + 'Tests out of sequence. Found (99999) but expected (5)', + 'Tests out of sequence. Found (100000) but expected (6)', + 'Tests out of sequence. Found (100001) but expected (7)', + 'Tests out of sequence. Found (100002) but expected (8)', + 'Tests out of sequence. Found (100003) but expected (9)', + 'Tests out of sequence. Found (100004) but expected (10)', + 'Tests out of sequence. Found (100005) but expected (11)', + 'Bad plan. You planned 2 tests but ran 11.' + ], + 'exit' => 0, + wait => 0, + }, + combined => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..10', + tests_planned => 10, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => 'basset hounds got long ears', + explanation => '', + }, + { actual_passed => FALSE, + is_actual_ok => FALSE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => 'all hell broke loose', + explanation => '', + }, + { actual_passed => FALSE, + is_actual_ok => FALSE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => TRUE, + number => 4, + description => '', + explanation => 'if I heard a voice from heaven ...', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => 'say "live without loving",', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 6, + description => "I'd beg off.", + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => '1', + has_todo => FALSE, + number => 7, + description => '', + explanation => 'contract negotiations', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 8, + description => 'Girls are such exquisite hell', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => TRUE, + number => 9, + description => 'Elegy 9B', + explanation => '', + }, + { actual_passed => FALSE, + is_actual_ok => FALSE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 10, + description => '', + explanation => '', + }, + ], + plan => '1..10', + passed => [ 1 .. 2, 4 .. 9 ], + actual_passed => [ 1 .. 2, 5 .. 9 ], + failed => [ 3, 10 ], + actual_failed => [ 3, 4, 10 ], + todo => [ 4, 9 ], + todo_passed => [9], + skipped => [7], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 10, + tests_run => 10, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + head_end => { + results => [ + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'comments', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => '', + explanation => '', + }, + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'comment', + }, + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..4', + tests_planned => 4, + }, + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'more ignored stuff', + }, + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'and yet more', + }, + ], + plan => '1..4', + passed => [ 1 .. 4 ], + actual_passed => [ 1 .. 4 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 4, + tests_run => 4, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + head_fail => { + results => [ + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'comments', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => '', + explanation => '', + }, + { actual_passed => FALSE, + is_actual_ok => FALSE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => '', + explanation => '', + }, + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'comment', + }, + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..4', + tests_planned => 4, + }, + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'more ignored stuff', + }, + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'and yet more', + }, + ], + plan => '1..4', + passed => [ 1, 3, 4 ], + actual_passed => [ 1, 3, 4 ], + failed => [2], + actual_failed => [2], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 4, + tests_run => 4, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + out_of_order => { + results => [ + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => '- Test that argument passing works', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => + '- Test that passing arguments as references work', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => '- Test a normal sub', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 6, + description => '- Detach test', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 8, + description => '- Nested thread test', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 9, + description => '- Nested thread test', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 10, + description => '- Wanted 7, got 7', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 11, + description => '- Wanted 7, got 7', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 12, + description => '- Wanted 8, got 8', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 13, + description => '- Wanted 8, got 8', + explanation => '', + }, + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..15', + tests_planned => 15, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => '- Check that Config::threads is true', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 7, + description => '- Detach test', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 14, + description => + '- Check so that tid for threads work for main thread', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 15, + description => + '- Check so that tid for threads work for main thread', + explanation => '', + }, + ], + plan => '1..15', + passed => [ 2 .. 4, 6, 8 .. 13, 1, 5, 7, 14, 15 ], + actual_passed => [ 2 .. 4, 6, 8 .. 13, 1, 5, 7, 14, 15 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + is_good_plan => FALSE, + tests_planned => 15, + tests_run => 15, + + # Note that tests 14 and 15 *are* in the correct sequence. + parse_errors => [ + 'Tests out of sequence. Found (2) but expected (1)', + 'Tests out of sequence. Found (3) but expected (2)', + 'Tests out of sequence. Found (4) but expected (3)', + 'Tests out of sequence. Found (6) but expected (4)', + 'Tests out of sequence. Found (8) but expected (5)', + 'Tests out of sequence. Found (9) but expected (6)', + 'Tests out of sequence. Found (10) but expected (7)', + 'Tests out of sequence. Found (11) but expected (8)', + 'Tests out of sequence. Found (12) but expected (9)', + 'Tests out of sequence. Found (13) but expected (10)', + 'Plan (1..15) must be at the beginning or end of the TAP output', + 'Tests out of sequence. Found (1) but expected (11)', + 'Tests out of sequence. Found (5) but expected (12)', + 'Tests out of sequence. Found (7) but expected (13)', + ], + 'exit' => 0, + wait => 0, + }, + skipall => { + results => [ + { is_plan => TRUE, + raw => '1..0 # skipping: rope', + tests_planned => 0, + passed => TRUE, + is_ok => TRUE, + directive => 'SKIP', + explanation => 'rope' + }, + ], + plan => '1..0', + passed => [], + actual_passed => [], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 0, + tests_run => 0, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + skip_all => 'rope', + }, + skipall_v13 => { + results => [ + { is_version => TRUE, + raw => 'TAP version 13', + }, + { is_unknown => TRUE, + raw => '1..0 # skipping: rope', + }, + ], + plan => '', + passed => [], + actual_passed => [], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => FALSE, + is_good_plan => FALSE, + tests_planned => FALSE, + tests_run => 0, + parse_errors => ['No plan found in TAP output'], + 'exit' => 0, + wait => 0, + version => 13, + }, + strict => { + results => [ + { is_version => TRUE, + raw => 'TAP version 13', + }, + { is_plan => TRUE, + raw => '1..1', + }, + { is_pragma => TRUE, + raw => 'pragma +strict', + pragmas => ['+strict'], + }, + { is_unknown => TRUE, raw => 'Nonsense!', + }, + { is_pragma => TRUE, + raw => 'pragma -strict', + pragmas => ['-strict'], + }, + { is_unknown => TRUE, + raw => "Doesn't matter.", + }, + { is_test => TRUE, + raw => 'ok 1 All OK', + } + ], + plan => '1..1', + passed => [1], + actual_passed => [1], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 1, + tests_run => 1, + parse_errors => ['Unknown TAP token: "Nonsense!"'], + 'exit' => 0, # TODO: Is this right??? + wait => 0, + version => 13, + }, + skipall_nomsg => { + results => [ + { is_plan => TRUE, + raw => '1..0', + tests_planned => 0, + passed => TRUE, + is_ok => TRUE, + directive => 'SKIP', + explanation => '' + }, + ], + plan => '1..0', + passed => [], + actual_passed => [], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 0, + tests_run => 0, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + skip_all => '(no reason given)', + }, + todo_misparse => { + results => [ + { is_plan => TRUE, + raw => '1..1', + tests_planned => TRUE, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => FALSE, + is_actual_ok => FALSE, + passed => FALSE, + is_ok => FALSE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => 'Hamlette # TODOORNOTTODO', + explanation => '', + }, + ], + plan => '1..1', + passed => [], + actual_passed => [], + failed => [1], + actual_failed => [1], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => TRUE, + tests_run => 1, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + shbang_misparse => { + results => [ + { is_plan => TRUE, + raw => '1..2', + tests_planned => 2, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + description => "", + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "", + }, + ], + plan => '1..2', + passed => [ 1 .. 2 ], + actual_passed => [ 1 .. 2 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 2, + tests_run => 2, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + switches => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..1', + tests_planned => 1, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => "", + explanation => '', + }, + ], + __ARGS__ => { switches => ['-Mstrict'] }, + plan => '1..1', + passed => [1], + actual_passed => [1], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 1, + tests_run => TRUE, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + inc_taint => { + results => [ + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..1', + tests_planned => 1, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => "", + explanation => '', + }, + ], + __ARGS__ => { switches => ['-Iexamples'] }, + plan => '1..1', + passed => [1], + actual_passed => [1], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 1, + tests_run => TRUE, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + sequence_misparse => { + results => [ + { is_plan => TRUE, + raw => '1..5', + tests_planned => 5, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "\# skipped on foobar system", + }, + { is_comment => TRUE, + comment => '1234567890123456789012345678901234567890', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + }, + { is_comment => TRUE, + comment => '1234567890123456789012345678901234567890', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + }, + ], + plan => '1..5', + passed => [ 1 .. 5 ], + actual_passed => [ 1 .. 5 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + + # For some reason mixing stdout with stderr is unreliable on Windows + ( $IsWin32 + ? () + : ( stdout_stderr => { + results => [ + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'comments', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => '', + explanation => '', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => '', + explanation => '', + }, + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'comment', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => '', + explanation => '', + }, + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'more ignored stuff', + }, + { is_comment => TRUE, + passed => TRUE, + is_ok => TRUE, + comment => 'and yet more', + }, + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..4', + tests_planned => 4, + }, + ], + plan => '1..4', + passed => [ 1 .. 4 ], + actual_passed => [ 1 .. 4 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 4, + tests_run => 4, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + need_open3 => 1, + } + ) + ), + + junk_before_plan => { + results => [ + { is_unknown => TRUE, + raw => 'this is junk', + }, + { is_comment => TRUE, + comment => "this is a comment", + }, + { is_plan => TRUE, + passed => TRUE, + is_ok => TRUE, + raw => '1..1', + tests_planned => 1, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + }, + ], + plan => '1..1', + passed => [ 1 .. 1 ], + actual_passed => [ 1 .. 1 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 1, + tests_run => 1, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + version_good => { + results => [ + { is_version => TRUE, + raw => 'TAP version 13', + }, + { is_plan => TRUE, + raw => '1..5', + tests_planned => 5, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + }, + ], + plan => '1..5', + passed => [ 1 .. 5 ], + actual_passed => [ 1 .. 5 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 13, + }, + version_old => { + results => [ + { is_version => TRUE, + raw => 'TAP version 12', + }, + { is_plan => TRUE, + raw => '1..5', + tests_planned => 5, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + }, + ], + plan => '1..5', + passed => [ 1 .. 5 ], + actual_passed => [ 1 .. 5 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => + ['Explicit TAP version must be at least 13. Got version 12'], + 'exit' => 0, + wait => 0, + version => 12, + }, + version_late => { + results => [ + { is_plan => TRUE, + raw => '1..5', + tests_planned => 5, + passed => TRUE, + is_ok => TRUE, + }, + { is_version => TRUE, + raw => 'TAP version 13', + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 4, + description => "", + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + description => "", + }, + ], + plan => '1..5', + passed => [ 1 .. 5 ], + actual_passed => [ 1 .. 5 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => + ['If TAP version is present it must be the first line of output'], + 'exit' => 0, + wait => 0, + version => 12, + }, + + escape_eol => { + results => [ + { is_plan => TRUE, + raw => '1..2', + tests_planned => 2, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + description => + 'Should parse as literal backslash --> \\', + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => 'Not a continuation line', + is_unplanned => FALSE, + }, + ], + plan => '1..2', + passed => [ 1 .. 2 ], + actual_passed => [ 1 .. 2 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 2, + tests_run => 2, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + + escape_hash => { + results => [ + { is_plan => TRUE, + raw => '1..3', + tests_planned => 3, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + description => 'Not a \\# TODO', + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + description => 'Not a \\# SKIP', + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + description => 'Escaped \\\\\\#', + is_unplanned => FALSE, + }, + ], + plan => '1..3', + passed => [ 1 .. 3 ], + actual_passed => [ 1 .. 3 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 3, + tests_run => 3, + parse_errors => [], + 'exit' => 0, + wait => 0, + version => 12, + }, + + zero_valid => { + results => [ + { is_plan => TRUE, + raw => '1..5', + tests_planned => 5, + passed => TRUE, + is_ok => TRUE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + description => '- One', + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 1, + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + description => '- Two', + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 2, + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + description => '- Three', + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 3, + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + description => '- Four', + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 0, + is_unplanned => FALSE, + }, + { actual_passed => TRUE, + is_actual_ok => TRUE, + description => '- Five', + passed => TRUE, + is_ok => TRUE, + is_test => TRUE, + has_skip => FALSE, + has_todo => FALSE, + number => 5, + is_unplanned => FALSE, + }, + ], + plan => '1..5', + passed => [ 1 .. 3, 0, 5 ], + actual_passed => [ 1 .. 3, 0, 5 ], + failed => [], + actual_failed => [], + todo => [], + todo_passed => [], + skipped => [], + good_plan => TRUE, + is_good_plan => TRUE, + tests_planned => 5, + tests_run => 5, + parse_errors => [ + 'Tests out of sequence. Found (0) but expected (4)', + ], + 'exit' => 0, + wait => 0, + version => 12, + }, +); + +my %HANDLER_FOR = ( + NOT_ZERO, sub { local $^W; 0 != shift }, + TRUE, sub { local $^W; !!shift }, + FALSE, sub { local $^W; !shift }, +); + +my $can_open3 = ( $Config{d_fork} || $IsWin32 ) ? 1 : 0; + +for my $hide_fork ( 0 .. $can_open3 ) { + if ($hide_fork) { + no strict 'refs'; + local $^W = 0; + *{'TAP::Parser::Iterator::Process::_use_open3'} = sub {return}; + } + + TEST: + for my $test ( sort keys %samples ) { + + #next unless 'empty' eq $test; + my %details = %{ $samples{$test} }; + + if ( my $skip_if = delete $details{skip_if} ) { + next TEST if $skip_if->(); + } + + my $results = delete $details{results}; + my $args = delete $details{__ARGS__}; + my $need_open3 = delete $details{need_open3}; + + next TEST if $need_open3 && ( $hide_fork || !$can_open3 ); + + # the following acrobatics are necessary to make it easy for the + # Test::Builder::failure_output() method to be overridden when + # TAP::Parser is not installed. Otherwise, these tests will fail. + + unshift @{ $args->{switches} }, + $ENV{PERL_CORE} ? ( map {"-I$_"} @INC ) : ('-It/lib'); + + $args->{source} = File::Spec->catfile( $SAMPLE_TESTS, $test ); + $args->{merge} = !$hide_fork; + + my $parser = eval { analyze_test( $test, [@$results], $args ) }; + my $error = $@; + ok !$error, "'$test' should parse successfully" + or diag $error; + + if ($error) { + my $tests = 0; + while ( my ( $method, $answer ) = each %details ) { + $tests += ref $answer ? 2 : 1; + } + SKIP: { + skip "$test did not parse successfully", $tests; + } + } + else { + while ( my ( $method, $answer ) = each %details ) { + if ( my $handler = $HANDLER_FOR{ $answer || '' } ) { # yuck + ok $handler->( $parser->$method() ), + "... and $method should return a reasonable value ($test)"; + } + elsif ( !ref $answer ) { + local $^W; # uninit warnings + + $answer = _vmsify_answer( $method, $answer ); + + is $parser->$method(), $answer, + "... and $method should equal $answer ($test)"; + } + else { + is scalar $parser->$method(), scalar @$answer, + "... and $method should be the correct amount ($test)"; + is_deeply [ $parser->$method() ], $answer, + "... and $method should be the correct values ($test)"; + } + } + } + } +} + +my %Unix2VMS_Exit_Codes = ( 1 => 4, ); + +sub _vmsify_answer { + my ( $method, $answer ) = @_; + + return $answer unless $IsVMS; + + if ( $method eq 'exit' + and exists $Unix2VMS_Exit_Codes{$answer} ) + { + $answer = $Unix2VMS_Exit_Codes{$answer}; + } + + return $answer; +} + +sub analyze_test { + my ( $test, $results, $args ) = @_; + + my $parser = TAP::Parser->new($args); + my $count = 1; + while ( defined( my $result = $parser->next ) ) { + + my $expected = shift @$results; + my $desc + = $result->is_test + ? $result->description + : $result->raw; + $desc = $result->plan + if $result->is_plan && $desc =~ /SKIP/i; + $desc =~ s/#/<hash>/g; + $desc =~ s/\s+/ /g; # Drop newlines + ok defined $expected, + "$test/$count We should have a result for $desc"; + while ( my ( $method, $answer ) = each %$expected ) { + + if ( my $handler = $HANDLER_FOR{ $answer || '' } ) { # yuck + ok $handler->( $result->$method() ), + "... and $method should return a reasonable value ($test/$count)"; + } + elsif ( ref $answer ) { + is_deeply scalar( $result->$method() ), $answer, + "... and $method should return the correct structure ($test/$count)"; + } + else { + is $result->$method(), $answer, + "... and $method should return the correct answer ($test/$count)"; + } + } + $count++; + } + is @$results, 0, + "... and we should have the correct number of results ($test)"; + return $parser; +} + +# vms_nit diff --git a/cpan/Test-Harness/t/results.t b/cpan/Test-Harness/t/results.t new file mode 100644 index 0000000000..0522dd6299 --- /dev/null +++ b/cpan/Test-Harness/t/results.t @@ -0,0 +1,295 @@ +#!/usr/bin/perl -wT + +use strict; +use lib 't/lib'; + +use Test::More tests => 227; + +use TAP::Parser::ResultFactory; +use TAP::Parser::Result; + +use constant RESULT => 'TAP::Parser::Result'; +use constant PLAN => 'TAP::Parser::Result::Plan'; +use constant TEST => 'TAP::Parser::Result::Test'; +use constant COMMENT => 'TAP::Parser::Result::Comment'; +use constant BAILOUT => 'TAP::Parser::Result::Bailout'; +use constant UNKNOWN => 'TAP::Parser::Result::Unknown'; + +my $warning; +$SIG{__WARN__} = sub { $warning = shift }; + +# +# Note that the are basic unit tests. More comprehensive path coverage is +# found in the regression tests. +# + +my $factory = TAP::Parser::ResultFactory->new; +my %inherited_methods = ( + is_plan => '', + is_test => '', + is_comment => '', + is_bailout => '', + is_unknown => '', + is_ok => 1, +); + +my $abstract_class = bless { type => 'no_such_type' }, + RESULT; # you didn't see this +run_method_tests( $abstract_class, {} ); # check the defaults + +can_ok $abstract_class, 'type'; +is $abstract_class->type, 'no_such_type', + '... and &type should return the correct result'; + +can_ok $abstract_class, 'passed'; +$warning = ''; +ok $abstract_class->passed, '... and it should default to true'; +like $warning, qr/^\Qpassed() is deprecated. Please use "is_ok()"/, + '... but it should emit a deprecation warning'; + +can_ok RESULT, 'new'; + +can_ok $factory, 'make_result'; +eval { $factory->make_result( { type => 'no_such_type' } ) }; +ok my $error = $@, '... and calling it with an unknown class should fail'; +like $error, qr/^Could not determine class for.*no_such_type/s, + '... with an appropriate error message'; + +# register new Result types: +can_ok $factory, 'class_for'; +can_ok $factory, 'register_type'; +{ + + package MyResult; + use strict; + use vars qw($VERSION @ISA); + @ISA = 'TAP::Parser::Result'; + TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ ); +} + +{ + my $r = eval { $factory->make_result( { type => 'my_type' } ) }; + my $error = $@; + isa_ok( $r, 'MyResult', 'register custom type' ); + ok( !$error, '... and no error' ); +} + +# +# test unknown tokens +# + +run_tests( + { class => UNKNOWN, + data => { + type => 'unknown', + raw => '... this line is junk ... ', + }, + }, + { is_unknown => 1, + raw => '... this line is junk ... ', + as_string => '... this line is junk ... ', + type => 'unknown', + has_directive => '', + } +); + +# +# test comment tokens +# + +run_tests( + { class => COMMENT, + data => { + type => 'comment', + raw => '# this is a comment', + comment => 'this is a comment', + }, + }, + { is_comment => 1, + raw => '# this is a comment', + as_string => '# this is a comment', + comment => 'this is a comment', + type => 'comment', + has_directive => '', + } +); + +# +# test bailout tokens +# + +run_tests( + { class => BAILOUT, + data => { + type => 'bailout', + raw => 'Bailout! This blows!', + bailout => 'This blows!', + }, + }, + { is_bailout => 1, + raw => 'Bailout! This blows!', + as_string => 'This blows!', + type => 'bailout', + has_directive => '', + } +); + +# +# test plan tokens +# + +run_tests( + { class => PLAN, + data => { + type => 'plan', + raw => '1..20', + tests_planned => 20, + directive => '', + explanation => '', + }, + }, + { is_plan => 1, + raw => '1..20', + tests_planned => 20, + directive => '', + explanation => '', + has_directive => '', + } +); + +run_tests( + { class => PLAN, + data => { + type => 'plan', + raw => '1..0 # SKIP help me, Rhonda!', + tests_planned => 0, + directive => 'SKIP', + explanation => 'help me, Rhonda!', + }, + }, + { is_plan => 1, + raw => '1..0 # SKIP help me, Rhonda!', + tests_planned => 0, + directive => 'SKIP', + explanation => 'help me, Rhonda!', + has_directive => 1, + } +); + +# +# test 'test' tokens +# + +my $test = run_tests( + { class => TEST, + data => { + ok => 'ok', + test_num => 5, + description => '... and this test is fine', + directive => '', + explanation => '', + raw => 'ok 5 and this test is fine', + type => 'test', + }, + }, + { is_test => 1, + type => 'test', + ok => 'ok', + number => 5, + description => '... and this test is fine', + directive => '', + explanation => '', + is_ok => 1, + is_actual_ok => 1, + todo_passed => '', + has_skip => '', + has_todo => '', + as_string => 'ok 5 ... and this test is fine', + is_unplanned => '', + has_directive => '', + } +); + +can_ok $test, 'actual_passed'; +$warning = ''; +is $test->actual_passed, $test->is_actual_ok, + '... and it should return the correct value'; +like $warning, + qr/^\Qactual_passed() is deprecated. Please use "is_actual_ok()"/, + '... but issue a deprecation warning'; + +can_ok $test, 'todo_failed'; +$warning = ''; +is $test->todo_failed, $test->todo_passed, + '... and it should return the correct value'; +like $warning, + qr/^\Qtodo_failed() is deprecated. Please use "todo_passed()"/, + '... but issue a deprecation warning'; + +# TODO directive + +$test = run_tests( + { class => TEST, + data => { + ok => 'not ok', + test_num => 5, + description => '... and this test is fine', + directive => 'TODO', + explanation => 'why not?', + raw => 'not ok 5 and this test is fine # TODO why not?', + type => 'test', + }, + }, + { is_test => 1, + type => 'test', + ok => 'not ok', + number => 5, + description => '... and this test is fine', + directive => 'TODO', + explanation => 'why not?', + is_ok => 1, + is_actual_ok => '', + todo_passed => '', + has_skip => '', + has_todo => 1, + as_string => + 'not ok 5 ... and this test is fine # TODO why not?', + is_unplanned => '', + has_directive => 1, + } +); + +sub run_tests { + my ( $instantiated, $value_for ) = @_; + my $result = instantiate($instantiated); + run_method_tests( $result, $value_for ); + return $result; +} + +sub instantiate { + my $instantiated = shift; + my $class = $instantiated->{class}; + ok my $result = $factory->make_result( $instantiated->{data} ), + 'Creating $class results should succeed'; + isa_ok $result, $class, '.. and the object it returns'; + return $result; +} + +sub run_method_tests { + my ( $result, $value_for ) = @_; + while ( my ( $method, $default ) = each %inherited_methods ) { + can_ok $result, $method; + if ( defined( my $value = delete $value_for->{$method} ) ) { + is $result->$method(), $value, + "... and $method should be correct"; + } + else { + is $result->$method(), $default, + "... and $method default should be correct"; + } + } + while ( my ( $method, $value ) = each %$value_for ) { + can_ok $result, $method; + is $result->$method(), $value, "... and $method should be correct"; + } +} diff --git a/cpan/Test-Harness/t/sample-tests/bailout b/cpan/Test-Harness/t/sample-tests/bailout new file mode 100644 index 0000000000..b25f417b52 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/bailout @@ -0,0 +1,11 @@ +# Sleep makes Mac OS open3 race problem more repeatable +sleep 1; +print <<DUMMY_TEST; +1..5 +ok 1 +ok 2 +ok 3 +Bail out! GERONIMMMOOOOOO!!! +ok 4 +ok 5 +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/bignum b/cpan/Test-Harness/t/sample-tests/bignum new file mode 100644 index 0000000000..b5824a12a1 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/bignum @@ -0,0 +1,7 @@ +print <<DUMMY; +1..2 +ok 1 +ok 2 +ok 136211425 +ok 136211426 +DUMMY diff --git a/cpan/Test-Harness/t/sample-tests/bignum_many b/cpan/Test-Harness/t/sample-tests/bignum_many new file mode 100644 index 0000000000..1e30b2f1dd --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/bignum_many @@ -0,0 +1,14 @@ +print <<DUMMY; +1..2 +ok 1 +ok 2 +ok 99997 +ok 99998 +ok 99999 +ok 100000 +ok 100001 +ok 100002 +ok 100003 +ok 100004 +ok 100005 +DUMMY diff --git a/cpan/Test-Harness/t/sample-tests/combined b/cpan/Test-Harness/t/sample-tests/combined new file mode 100644 index 0000000000..7e157092b3 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/combined @@ -0,0 +1,13 @@ +print <<DUMMY_TEST; +1..10 +ok 1 +ok 2 basset hounds got long ears +not ok 3 all hell broke loose +not ok 4 # TODO if I heard a voice from heaven ... +ok say "live without loving", +ok 6 I'd beg off. +ok 7 # Skip contract negotiations +ok 8 Girls are such exquisite hell +ok 9 Elegy 9B # TOdO +not ok 10 +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/combined_compat b/cpan/Test-Harness/t/sample-tests/combined_compat new file mode 100644 index 0000000000..8dfaa28e92 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/combined_compat @@ -0,0 +1,13 @@ +print <<DUMMY_TEST; +1..10 todo 4 10 +ok 1 +ok 2 basset hounds got long ears +not ok 3 all hell broke lose +ok 4 +ok +ok 6 +ok 7 # Skip contract negociations +ok 8 +not ok 9 +not ok 10 +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/delayed b/cpan/Test-Harness/t/sample-tests/delayed new file mode 100644 index 0000000000..1f24ef6790 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/delayed @@ -0,0 +1,26 @@ +# Used to test Process.pm +use Time::HiRes qw(sleep); + +my $delay = 0.01; + +$| = 1; + +my @parts = ( + "1.", + ".5\n", + "ok 1 00000\n", + "ok 2\nnot", + " ok 3", + "\nok 4\nok ", + "5 00000", + "" +); + +my $delay_at = shift || 0; + +while (@parts) { + sleep $delay if ( $delay_at & 1 ); + $delay_at >>= 1; + print shift @parts; +} +sleep $delay if ( $delay_at & 1 ); diff --git a/cpan/Test-Harness/t/sample-tests/descriptive b/cpan/Test-Harness/t/sample-tests/descriptive new file mode 100644 index 0000000000..e165ac1bf5 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/descriptive @@ -0,0 +1,8 @@ +print <<DUMMY_TEST; +1..5 +ok 1 Interlock activated +ok 2 Megathrusters are go +ok 3 Head formed +ok 4 Blazing sword formed +ok 5 Robeast destroyed +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/descriptive_trailing b/cpan/Test-Harness/t/sample-tests/descriptive_trailing new file mode 100644 index 0000000000..f92d7ca694 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/descriptive_trailing @@ -0,0 +1,8 @@ +print <<DUMMY_TEST; +ok 1 Interlock activated +ok 2 Megathrusters are go +ok 3 Head formed +ok 4 Blazing sword formed +ok 5 Robeast destroyed +1..5 +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/die b/cpan/Test-Harness/t/sample-tests/die new file mode 100644 index 0000000000..ca8b0a9b0b --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/die @@ -0,0 +1,2 @@ +eval "use vmsish 'hushed'" if ($^O eq 'VMS'); +exit 1; # exit because die() can be noisy diff --git a/cpan/Test-Harness/t/sample-tests/die_head_end b/cpan/Test-Harness/t/sample-tests/die_head_end new file mode 100644 index 0000000000..494e4d3c82 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/die_head_end @@ -0,0 +1,9 @@ +print <<DUMMY_TEST; +ok 1 +ok 2 +ok 3 +ok 4 +DUMMY_TEST + +eval "use vmsish 'hushed'" if ($^O eq 'VMS'); +exit 1; diff --git a/cpan/Test-Harness/t/sample-tests/die_last_minute b/cpan/Test-Harness/t/sample-tests/die_last_minute new file mode 100644 index 0000000000..ea533d628e --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/die_last_minute @@ -0,0 +1,10 @@ +print <<DUMMY_TEST; +ok 1 +ok 2 +ok 3 +ok 4 +1..4 +DUMMY_TEST + +eval "use vmsish 'hushed'" if ($^O eq 'VMS'); +exit 1; diff --git a/cpan/Test-Harness/t/sample-tests/die_unfinished b/cpan/Test-Harness/t/sample-tests/die_unfinished new file mode 100644 index 0000000000..3efd08ff09 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/die_unfinished @@ -0,0 +1,9 @@ +print <<DUMMY_TEST; +1..4 +ok 1 +ok 2 +ok 3 +DUMMY_TEST + +eval "use vmsish 'hushed'" if ($^O eq 'VMS'); +exit 1; diff --git a/cpan/Test-Harness/t/sample-tests/duplicates b/cpan/Test-Harness/t/sample-tests/duplicates new file mode 100644 index 0000000000..63f6a706b6 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/duplicates @@ -0,0 +1,14 @@ +print <<DUMMY_TEST +1..10 +ok 1 +ok 2 +ok 3 +ok 4 +ok 4 +ok 5 +ok 6 +ok 7 +ok 8 +ok 9 +ok 10 +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/echo b/cpan/Test-Harness/t/sample-tests/echo new file mode 100644 index 0000000000..6696e71f17 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/echo @@ -0,0 +1,2 @@ +print '1..', scalar(@ARGV), "\n"; +print "ok $_ ", $ARGV[ $_ - 1 ], "\n" for 1 .. @ARGV; diff --git a/cpan/Test-Harness/t/sample-tests/empty b/cpan/Test-Harness/t/sample-tests/empty new file mode 100644 index 0000000000..66d42ad402 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/empty @@ -0,0 +1,2 @@ +__END__ +Used to exercise the "empty test" case. diff --git a/cpan/Test-Harness/t/sample-tests/escape_eol b/cpan/Test-Harness/t/sample-tests/escape_eol new file mode 100644 index 0000000000..1b8ba27f1e --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/escape_eol @@ -0,0 +1,5 @@ +print <<DUMMY_TEST; +1..2 +ok 1 Should parse as literal backslash --> \\ +ok 2 Not a continuation line +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/escape_hash b/cpan/Test-Harness/t/sample-tests/escape_hash new file mode 100644 index 0000000000..c404372c0c --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/escape_hash @@ -0,0 +1,6 @@ +print <<DUMMY_TEST; +1..3 +ok 1 Not a \\# TODO +ok 2 Not a \\# SKIP +ok 3 Escaped \\\\\\# +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/head_end b/cpan/Test-Harness/t/sample-tests/head_end new file mode 100644 index 0000000000..14a32f2fe6 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/head_end @@ -0,0 +1,11 @@ +print <<DUMMY_TEST; +# comments +ok 1 +ok 2 +ok 3 +ok 4 +# comment +1..4 +# more ignored stuff +# and yet more +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/head_fail b/cpan/Test-Harness/t/sample-tests/head_fail new file mode 100644 index 0000000000..9d1667ab19 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/head_fail @@ -0,0 +1,11 @@ +print <<DUMMY_TEST; +# comments +ok 1 +not ok 2 +ok 3 +ok 4 +# comment +1..4 +# more ignored stuff +# and yet more +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/inc_taint b/cpan/Test-Harness/t/sample-tests/inc_taint new file mode 100644 index 0000000000..d1be66706c --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/inc_taint @@ -0,0 +1,6 @@ +#!/usr/bin/perl -Tw + +use Test::More tests => 1; + +ok( grep( /examples/, @INC ) ); + diff --git a/cpan/Test-Harness/t/sample-tests/junk_before_plan b/cpan/Test-Harness/t/sample-tests/junk_before_plan new file mode 100644 index 0000000000..b2ad018301 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/junk_before_plan @@ -0,0 +1,6 @@ +print <<DUMMY_TEST; +this is junk +# this is a comment +1..1 +ok 1 +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/lone_not_bug b/cpan/Test-Harness/t/sample-tests/lone_not_bug new file mode 100644 index 0000000000..10eaa2a3b0 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/lone_not_bug @@ -0,0 +1,9 @@ +# There was a bug where the first test would be considered a +# 'lone not' failure. +print <<DUMMY; +ok 1 +ok 2 +ok 3 +ok 4 +1..4 +DUMMY diff --git a/cpan/Test-Harness/t/sample-tests/no_nums b/cpan/Test-Harness/t/sample-tests/no_nums new file mode 100644 index 0000000000..c32d3f22ba --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/no_nums @@ -0,0 +1,8 @@ +print <<DUMMY_TEST; +1..5 +ok +ok +not ok +ok +ok +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/no_output b/cpan/Test-Harness/t/sample-tests/no_output new file mode 100644 index 0000000000..505acda7e6 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/no_output @@ -0,0 +1,3 @@ +#!/usr/bin/perl -w + +exit; diff --git a/cpan/Test-Harness/t/sample-tests/out_err_mix b/cpan/Test-Harness/t/sample-tests/out_err_mix new file mode 100644 index 0000000000..c802eb4a11 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/out_err_mix @@ -0,0 +1,13 @@ +sub _autoflush { + my $flushed = shift; + my $old_fh = select $flushed; + $| = 1; + select $old_fh; +} + +_autoflush( \*STDOUT ); +_autoflush( \*STDERR ); + +print STDOUT "one\n"; +print STDERR "two\n\n"; +print STDOUT "three\n"; diff --git a/cpan/Test-Harness/t/sample-tests/out_of_order b/cpan/Test-Harness/t/sample-tests/out_of_order new file mode 100644 index 0000000000..77641aa362 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/out_of_order @@ -0,0 +1,22 @@ +# From a bungled core thread test. +# +# The important thing here is that the last test is the right test. +# Test::Harness would misparse this as being a valid test. +print <<DUMMY; +ok 2 - Test that argument passing works +ok 3 - Test that passing arguments as references work +ok 4 - Test a normal sub +ok 6 - Detach test +ok 8 - Nested thread test +ok 9 - Nested thread test +ok 10 - Wanted 7, got 7 +ok 11 - Wanted 7, got 7 +ok 12 - Wanted 8, got 8 +ok 13 - Wanted 8, got 8 +1..15 +ok 1 +ok 5 - Check that Config::threads is true +ok 7 - Detach test +ok 14 - Check so that tid for threads work for main thread +ok 15 - Check so that tid for threads work for main thread +DUMMY diff --git a/cpan/Test-Harness/t/sample-tests/schwern b/cpan/Test-Harness/t/sample-tests/schwern new file mode 100644 index 0000000000..d45726bc7a --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/schwern @@ -0,0 +1,3 @@ +use Test::More; +plan tests => 1; +ok 23, 42; diff --git a/cpan/Test-Harness/t/sample-tests/schwern-todo-quiet b/cpan/Test-Harness/t/sample-tests/schwern-todo-quiet new file mode 100644 index 0000000000..4d482d43fa --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/schwern-todo-quiet @@ -0,0 +1,13 @@ +print <<DUMMY_TEST; +1..3 +ok 1 +not ok 2 +# Failed test at ../../andy/schwern.pl line 17. +# got: '23' +# expected: '42' +not ok 3 # TODO Roman numerials still not a built in type +# Failed (TODO) test at ../../andy/schwern.pl line 20. +# got: 'XXIII' +# expected: '23' +# Looks like you failed 1 test of 3. +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/segfault b/cpan/Test-Harness/t/sample-tests/segfault new file mode 100644 index 0000000000..c5670a42b5 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/segfault @@ -0,0 +1,5 @@ +#!/usr/bin/perl + +print "1..1\n"; +print "ok 1\n"; +kill 11, $$; diff --git a/cpan/Test-Harness/t/sample-tests/sequence_misparse b/cpan/Test-Harness/t/sample-tests/sequence_misparse new file mode 100644 index 0000000000..c66d127bb0 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/sequence_misparse @@ -0,0 +1,14 @@ +# +# This was causing parse failures due to an error in the TAP specification. +# Hash marks *are* allowed in the description. +# +print <<DUMMY; +1..5 +ok 1 +ok 2 +ok 3 # skipped on foobar system +# 1234567890123456789012345678901234567890 +ok 4 +# 1234567890123456789012345678901234567890 +ok 5 +DUMMY diff --git a/cpan/Test-Harness/t/sample-tests/shbang_misparse b/cpan/Test-Harness/t/sample-tests/shbang_misparse new file mode 100644 index 0000000000..ab93b468ae --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/shbang_misparse @@ -0,0 +1,12 @@ +#!/usr/bin/perl-latest + +# The above #! line was misparsed as having a -t. +# Pre-5.8 this will simply cause perl to choke, since there was no -t. +# Post-5.8 taint warnings will mistakenly be on. + +print "1..2\n"; +print "ok 1\n"; +my $warning = ''; +$SIG{__WARN__} = sub { $warning .= $_[0] }; +eval( "#" . substr( $0, 0, 0 ) ); +print $warning ? "not ok 2\n" : "ok 2\n"; diff --git a/cpan/Test-Harness/t/sample-tests/simple b/cpan/Test-Harness/t/sample-tests/simple new file mode 100644 index 0000000000..d6b85846b2 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/simple @@ -0,0 +1,8 @@ +print <<DUMMY_TEST; +1..5 +ok 1 +ok 2 +ok 3 +ok 4 +ok 5 +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/simple_fail b/cpan/Test-Harness/t/sample-tests/simple_fail new file mode 100644 index 0000000000..aa65f5f66d --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/simple_fail @@ -0,0 +1,8 @@ +print <<DUMMY_TEST; +1..5 +ok 1 +not ok 2 +ok 3 +ok 4 +not ok 5 +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/simple_yaml b/cpan/Test-Harness/t/sample-tests/simple_yaml new file mode 100644 index 0000000000..9f52c5c8a8 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/simple_yaml @@ -0,0 +1,27 @@ +print <<DUMMY_TEST; +TAP version 13 +1..5 +ok 1 +ok 2 + --- + - + fnurk: skib + ponk: gleeb + - + bar: krup + foo: plink + ... +ok 3 +ok 4 + --- + expected: + - 1 + - 2 + - 4 + got: + - 1 + - pong + - 4 + ... +ok 5 +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/skip b/cpan/Test-Harness/t/sample-tests/skip new file mode 100644 index 0000000000..6a9cd662bc --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/skip @@ -0,0 +1,8 @@ +print <<DUMMY_TEST; +1..5 +ok 1 +ok 2 # skip rain delay +ok 3 +ok 4 +ok 5 +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/skip_nomsg b/cpan/Test-Harness/t/sample-tests/skip_nomsg new file mode 100644 index 0000000000..51d1ed6b43 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/skip_nomsg @@ -0,0 +1,4 @@ +print <<DUMMY; +1..1 +ok 1 # Skip +DUMMY diff --git a/cpan/Test-Harness/t/sample-tests/skipall b/cpan/Test-Harness/t/sample-tests/skipall new file mode 100644 index 0000000000..ceb2c19b3a --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/skipall @@ -0,0 +1,3 @@ +print <<DUMMY_TEST; +1..0 # skipping: rope +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/skipall_nomsg b/cpan/Test-Harness/t/sample-tests/skipall_nomsg new file mode 100644 index 0000000000..9b0dc11a69 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/skipall_nomsg @@ -0,0 +1,2 @@ +print "1..0\n"; +exit 0; diff --git a/cpan/Test-Harness/t/sample-tests/skipall_v13 b/cpan/Test-Harness/t/sample-tests/skipall_v13 new file mode 100644 index 0000000000..d16bd4f652 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/skipall_v13 @@ -0,0 +1,4 @@ +print <<DUMMY_TEST; +TAP version 13 +1..0 # skipping: rope +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/space_after_plan b/cpan/Test-Harness/t/sample-tests/space_after_plan new file mode 100644 index 0000000000..d454c20d4d --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/space_after_plan @@ -0,0 +1,3 @@ +# gforth TAP generates a space after the plan. Should probably be allowed. +print "1..5 \n"; +print "ok $_ \n" for 1..5; diff --git a/cpan/Test-Harness/t/sample-tests/stdout_stderr b/cpan/Test-Harness/t/sample-tests/stdout_stderr new file mode 100644 index 0000000000..ce17484d65 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/stdout_stderr @@ -0,0 +1,9 @@ +use Test::More 'no_plan'; +diag 'comments'; +ok 1; +ok 1; +ok 1; +diag 'comment'; +ok 1; +diag 'more ignored stuff'; +diag 'and yet more'; diff --git a/cpan/Test-Harness/t/sample-tests/strict b/cpan/Test-Harness/t/sample-tests/strict new file mode 100644 index 0000000000..b89138de40 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/strict @@ -0,0 +1,9 @@ +print <<DUMMY_TEST; +TAP version 13 +1..1 +pragma +strict +Nonsense! +pragma -strict +Doesn't matter. +ok 1 All OK +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/switches b/cpan/Test-Harness/t/sample-tests/switches new file mode 100644 index 0000000000..8ce9c9a589 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/switches @@ -0,0 +1,2 @@ +print "1..1\n"; +print $INC{'strict.pm'} ? "ok 1\n" : "not ok 1\n"; diff --git a/cpan/Test-Harness/t/sample-tests/taint b/cpan/Test-Harness/t/sample-tests/taint new file mode 100644 index 0000000000..c36698e042 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/taint @@ -0,0 +1,7 @@ +#!/usr/bin/perl -Tw + +use lib qw(t/lib); +use Test::More tests => 1; + +eval { `$^X -e1` }; +like( $@, '/^Insecure dependency/', '-T honored' ); diff --git a/cpan/Test-Harness/t/sample-tests/taint_warn b/cpan/Test-Harness/t/sample-tests/taint_warn new file mode 100644 index 0000000000..398d6181ee --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/taint_warn @@ -0,0 +1,11 @@ +#!/usr/bin/perl -tw + +use lib qw(t/lib); +use Test::More tests => 1; + +my $warnings = ''; +{ + local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; + `$^X -e1`; +} +like( $warnings, '/^Insecure dependency/', '-t honored' ); diff --git a/cpan/Test-Harness/t/sample-tests/todo b/cpan/Test-Harness/t/sample-tests/todo new file mode 100644 index 0000000000..77f00b4dc9 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/todo @@ -0,0 +1,8 @@ +print <<DUMMY_TEST; +1..5 todo 3 2; +ok 1 +ok 2 +not ok 3 +ok 4 +ok 5 +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/todo_inline b/cpan/Test-Harness/t/sample-tests/todo_inline new file mode 100644 index 0000000000..5b96d68caf --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/todo_inline @@ -0,0 +1,6 @@ +print <<DUMMY_TEST; +1..3 +not ok 1 - Foo # TODO Just testing the todo interface. +ok 2 - Unexpected success # TODO Just testing the todo interface. +ok 3 - This is not todo +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/todo_misparse b/cpan/Test-Harness/t/sample-tests/todo_misparse new file mode 100644 index 0000000000..138f3fbaaa --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/todo_misparse @@ -0,0 +1,5 @@ +print <<'END'; +1..1 +not ok 1 Hamlette # TODOORNOTTODO +END + diff --git a/cpan/Test-Harness/t/sample-tests/too_many b/cpan/Test-Harness/t/sample-tests/too_many new file mode 100644 index 0000000000..46acaded4d --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/too_many @@ -0,0 +1,14 @@ +print <<DUMMY; +1..3 +ok 1 +ok 2 +ok 3 +ok 4 +ok 5 +ok 6 +ok 7 +DUMMY + +exit 4; # simulate Test::More's exit status + + diff --git a/cpan/Test-Harness/t/sample-tests/version_good b/cpan/Test-Harness/t/sample-tests/version_good new file mode 100644 index 0000000000..9e4ab908a2 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/version_good @@ -0,0 +1,9 @@ +print <<DUMMY_TEST; +TAP version 13 +1..5 +ok 1 +ok 2 +ok 3 +ok 4 +ok 5 +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/version_late b/cpan/Test-Harness/t/sample-tests/version_late new file mode 100644 index 0000000000..4537a322e3 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/version_late @@ -0,0 +1,9 @@ +print <<DUMMY_TEST; +1..5 +TAP version 13 +ok 1 +ok 2 +ok 3 +ok 4 +ok 5 +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/version_old b/cpan/Test-Harness/t/sample-tests/version_old new file mode 100644 index 0000000000..3c0c44ffb1 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/version_old @@ -0,0 +1,9 @@ +print <<DUMMY_TEST; +TAP version 12 +1..5 +ok 1 +ok 2 +ok 3 +ok 4 +ok 5 +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/vms_nit b/cpan/Test-Harness/t/sample-tests/vms_nit new file mode 100644 index 0000000000..1df7804309 --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/vms_nit @@ -0,0 +1,6 @@ +print <<DUMMY; +1..2 +not +ok 1 +ok 2 +DUMMY diff --git a/cpan/Test-Harness/t/sample-tests/with_comments b/cpan/Test-Harness/t/sample-tests/with_comments new file mode 100644 index 0000000000..7aa913985b --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/with_comments @@ -0,0 +1,14 @@ +print <<DUMMY_TEST; +# and stuff +1..5 todo 1 2 4 5; +# yeah, that +not ok 1 +# Failed test 1 in t/todo.t at line 9 *TODO* +ok 2 # (t/todo.t at line 10 TODO?!) +ok 3 +not ok 4 +# Test 4 got: '0' (t/todo.t at line 12 *TODO*) +# Expected: '1' (need more tuits) +ok 5 # (t/todo.t at line 13 TODO?!) +# woo +DUMMY_TEST diff --git a/cpan/Test-Harness/t/sample-tests/zero_valid b/cpan/Test-Harness/t/sample-tests/zero_valid new file mode 100644 index 0000000000..dae91a18fb --- /dev/null +++ b/cpan/Test-Harness/t/sample-tests/zero_valid @@ -0,0 +1,8 @@ +print <<DUMMY; +1..5 +ok 1 - One +ok 2 - Two +ok - Three +ok 0 - Four +ok 5 - Five +DUMMY diff --git a/cpan/Test-Harness/t/scheduler.t b/cpan/Test-Harness/t/scheduler.t new file mode 100644 index 0000000000..b2742078b1 --- /dev/null +++ b/cpan/Test-Harness/t/scheduler.t @@ -0,0 +1,225 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; + +use Test::More; +use TAP::Parser::Scheduler; + +my $perl_rules = { + par => [ + { seq => '../ext/DB_File/t/*' }, + { seq => '../ext/IO_Compress_Zlib/t/*' }, + { seq => '../lib/CPANPLUS/*' }, + { seq => '../lib/ExtUtils/t/*' }, + '*' + ] +}; + +my $incomplete_rules = { par => [ { seq => [ '*A', '*D' ] } ] }; + +my $some_tests = [ + '../ext/DB_File/t/A', + 'foo', + '../ext/DB_File/t/B', + '../ext/DB_File/t/C', + '../lib/CPANPLUS/D', + '../lib/CPANPLUS/E', + 'bar', + '../lib/CPANPLUS/F', + '../ext/DB_File/t/D', + '../ext/DB_File/t/E', + '../ext/DB_File/t/F', +]; + +my @schedule = ( + { name => 'Sequential, no rules', + tests => $some_tests, + jobs => 1, + }, + { name => 'Sequential, Perl rules', + rules => $perl_rules, + tests => $some_tests, + jobs => 1, + }, + { name => 'Two in parallel, Perl rules', + rules => $perl_rules, + tests => $some_tests, + jobs => 2, + }, + { name => 'Massively parallel, Perl rules', + rules => $perl_rules, + tests => $some_tests, + jobs => 1000, + }, + { name => 'Massively parallel, no rules', + tests => $some_tests, + jobs => 1000, + }, + { name => 'Sequential, incomplete rules', + rules => $incomplete_rules, + tests => $some_tests, + jobs => 1, + }, + { name => 'Two in parallel, incomplete rules', + rules => $incomplete_rules, + tests => $some_tests, + jobs => 2, + }, + { name => 'Massively parallel, incomplete rules', + rules => $incomplete_rules, + tests => $some_tests, + jobs => 1000, + }, +); + +plan tests => @schedule * 2 + 266; + +for my $test (@schedule) { + test_scheduler( + $test->{name}, + $test->{tests}, + $test->{rules}, + $test->{jobs} + ); +} + +# An ad-hoc test + +{ + my @tests = qw( + A1 A2 A3 B1 C1 C8 C5 C7 C4 C6 C3 C2 C9 D1 D2 D3 E3 E2 E1 + ); + + my $rules = { + par => [ + { seq => 'A*' }, + { par => 'B*' }, + { seq => [ 'C1', 'C2' ] }, + { par => [ + { seq => [ 'C3', 'C4', 'C5' ] }, + { seq => [ 'C6', 'C7', 'C8' ] } + ] + }, + { seq => [ + { par => ['D*'] }, + { par => ['E*'] } + ] + }, + ] + }; + + my $scheduler = TAP::Parser::Scheduler->new( + tests => \@tests, + rules => $rules + ); + + # diag $scheduler->as_string; + + my $A1 = ok_job( $scheduler, 'A1' ); + my $B1 = ok_job( $scheduler, 'B1' ); + finish($A1); + my $A2 = ok_job( $scheduler, 'A2' ); + my $C1 = ok_job( $scheduler, 'C1' ); + finish( $A2, $C1 ); + my $A3 = ok_job( $scheduler, 'A3' ); + my $C2 = ok_job( $scheduler, 'C2' ); + finish( $A3, $C2 ); + my $C3 = ok_job( $scheduler, 'C3' ); + my $C6 = ok_job( $scheduler, 'C6' ); + my $D1 = ok_job( $scheduler, 'D1' ); + my $D2 = ok_job( $scheduler, 'D2' ); + finish($C6); + my $C7 = ok_job( $scheduler, 'C7' ); + my $D3 = ok_job( $scheduler, 'D3' ); + ok_job( $scheduler, '#' ); + ok_job( $scheduler, '#' ); + finish( $D3, $C3, $D1, $B1 ); + my $C4 = ok_job( $scheduler, 'C4' ); + finish( $C4, $C7 ); + my $C5 = ok_job( $scheduler, 'C5' ); + my $C8 = ok_job( $scheduler, 'C8' ); + ok_job( $scheduler, '#' ); + finish($D2); + my $E3 = ok_job( $scheduler, 'E3' ); + my $E2 = ok_job( $scheduler, 'E2' ); + my $E1 = ok_job( $scheduler, 'E1' ); + finish( $E1, $E2, $E3, $C5, $C8 ); + my $C9 = ok_job( $scheduler, 'C9' ); + ok_job( $scheduler, undef ); +} + +{ + my @tests = (); + for my $t ( 'A' .. 'Z' ) { + push @tests, map {"$t$_"} 1 .. 9; + } + my $rules = { par => [ map { { seq => "$_*" } } 'A' .. 'Z' ] }; + + my $scheduler = TAP::Parser::Scheduler->new( + tests => \@tests, + rules => $rules + ); + + # diag $scheduler->as_string; + + for my $n ( 1 .. 9 ) { + my @got = (); + push @got, ok_job( $scheduler, "$_$n" ) for 'A' .. 'Z'; + ok_job( $scheduler, $n == 9 ? undef : '#' ); + finish(@got); + } +} + +sub finish { $_->finish for @_ } + +sub ok_job { + my ( $scheduler, $want ) = @_; + my $job = $scheduler->get_job; + if ( !defined $want ) { + ok !defined $job, 'undef'; + } + elsif ( $want eq '#' ) { + ok $job->is_spinner, 'spinner'; + } + else { + is $job->filename, $want, $want; + } + return $job; +} + +sub test_scheduler { + my ( $name, $tests, $rules, $jobs ) = @_; + + ok my $scheduler = TAP::Parser::Scheduler->new( + tests => $tests, + defined $rules ? ( rules => $rules ) : (), + ), + "$name: new"; + + # diag $scheduler->as_string; + + my @pipeline = (); + my @got = (); + + while ( defined( my $job = $scheduler->get_job ) ) { + + # diag $scheduler->as_string; + if ( $job->is_spinner || @pipeline >= $jobs ) { + die "Oops! Spinner!" unless @pipeline; + my $done = shift @pipeline; + $done->finish; + + # diag "Completed ", $done->filename; + } + next if $job->is_spinner; + + # diag " Got ", $job->filename; + push @pipeline, $job; + + push @got, $job->filename; + } + + is_deeply [ sort @got ], [ sort @$tests ], "$name: got all tests"; +} + diff --git a/cpan/Test-Harness/t/source.t b/cpan/Test-Harness/t/source.t new file mode 100644 index 0000000000..ce9063e57b --- /dev/null +++ b/cpan/Test-Harness/t/source.t @@ -0,0 +1,93 @@ +#!/usr/bin/perl -w + +BEGIN { + unshift @INC, 't/lib'; +} + +use strict; + +use Test::More tests => 26; + +use File::Spec; + +use EmptyParser; +use TAP::Parser::Source; +use TAP::Parser::Source::Perl; + +my $parser = EmptyParser->new; +my $test = File::Spec->catfile( + 't', + 'source_tests', + 'source' +); + +my $perl = $^X; + +can_ok 'TAP::Parser::Source', 'new'; +my $source = TAP::Parser::Source->new; +isa_ok $source, 'TAP::Parser::Source'; + +can_ok $source, 'source'; +eval { $source->source("$perl -It/lib $test") }; +ok my $error = $@, '... and calling it with a string should fail'; +like $error, qr/^Argument to &source must be an array reference/, + '... with an appropriate error message'; +ok $source->source( [ $perl, '-It/lib', '-T', $test ] ), + '... and calling it with valid args should succeed'; + +can_ok $source, 'get_stream'; +my $stream = $source->get_stream($parser); + +isa_ok $stream, 'TAP::Parser::Iterator::Process', + 'get_stream returns the right object'; +can_ok $stream, 'next'; +is $stream->next, '1..1', '... and the first line should be correct'; +is $stream->next, 'ok 1', '... as should the second'; +ok !$stream->next, '... and we should have no more results'; + +can_ok 'TAP::Parser::Source::Perl', 'new'; +$source = TAP::Parser::Source::Perl->new; +isa_ok $source, 'TAP::Parser::Source::Perl', '... and the object it returns'; + +can_ok $source, 'source'; +ok $source->source( [$test] ), + '... and calling it with valid args should succeed'; + +can_ok $source, 'get_stream'; +$stream = $source->get_stream($parser); + +isa_ok $stream, 'TAP::Parser::Iterator::Process', + '... and the object it returns'; +can_ok $stream, 'next'; +is $stream->next, '1..1', '... and the first line should be correct'; +is $stream->next, 'ok 1', '... as should the second'; +ok !$stream->next, '... and we should have no more results'; + +# internals tests! + +can_ok $source, '_switches'; +ok( grep( $_ =~ /^['"]?-T['"]?$/, $source->_switches ), + '... and it should find the taint switch' +); + +# coverage test for TAP::PArser::Source + +{ + + # coverage for method get_steam + + my $source = TAP::Parser::Source->new( { parser => $parser } ); + + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + $source->get_stream; + }; + + is @die, 1, 'coverage testing of get_stream'; + + like pop @die, qr/No command found!/, '...and it failed as expect'; +} + diff --git a/cpan/Test-Harness/t/source_tests/harness b/cpan/Test-Harness/t/source_tests/harness new file mode 100644 index 0000000000..7fef7d5459 --- /dev/null +++ b/cpan/Test-Harness/t/source_tests/harness @@ -0,0 +1,6 @@ +#!/usr/bin/perl + +print <<'END_TESTS'; +1..1 +ok 1 - this is a test +END_TESTS diff --git a/cpan/Test-Harness/t/source_tests/harness_badtap b/cpan/Test-Harness/t/source_tests/harness_badtap new file mode 100644 index 0000000000..bf8233a5ca --- /dev/null +++ b/cpan/Test-Harness/t/source_tests/harness_badtap @@ -0,0 +1,8 @@ +#!/usr/bin/perl + +print <<'END_TESTS'; +1..2 +ok 1 - this is a test +not ok 2 - this is another test +1..2 +END_TESTS diff --git a/cpan/Test-Harness/t/source_tests/harness_complain b/cpan/Test-Harness/t/source_tests/harness_complain new file mode 100644 index 0000000000..1ef4cf0534 --- /dev/null +++ b/cpan/Test-Harness/t/source_tests/harness_complain @@ -0,0 +1,7 @@ +#!/usr/bin/perl + +print "1..1\n"; + +die "I should have no args -- @ARGV" if (@ARGV); +print "ok 1 - this is a test\n"; + diff --git a/cpan/Test-Harness/t/source_tests/harness_directives b/cpan/Test-Harness/t/source_tests/harness_directives new file mode 100644 index 0000000000..91ada58bf3 --- /dev/null +++ b/cpan/Test-Harness/t/source_tests/harness_directives @@ -0,0 +1,8 @@ +#!/usr/bin/perl + +print <<'END_TESTS'; +1..3 +ok 1 - this is a test +not ok 2 - we have a something # TODO some output +ok 3 houston, we don't have liftoff # SKIP no funding +END_TESTS diff --git a/cpan/Test-Harness/t/source_tests/harness_failure b/cpan/Test-Harness/t/source_tests/harness_failure new file mode 100644 index 0000000000..a36e5c129b --- /dev/null +++ b/cpan/Test-Harness/t/source_tests/harness_failure @@ -0,0 +1,11 @@ +#!/usr/bin/perl + +print <<'END_TESTS'; +1..2 +ok 1 - this is a test +not ok 2 - this is another test +# Failed test 'this is another test' +# in harness_failure.t at line 5. +# got: 'waffle' +# expected: 'yarblokos' +END_TESTS diff --git a/cpan/Test-Harness/t/source_tests/source b/cpan/Test-Harness/t/source_tests/source new file mode 100644 index 0000000000..be28995e63 --- /dev/null +++ b/cpan/Test-Harness/t/source_tests/source @@ -0,0 +1,14 @@ +#!/usr/bin/perl -wT + +BEGIN { + if ( $ENV{PERL_CORE} ) { + @INC = ( '../../lib', 't/lib' ); + } + else { + unshift @INC, 't/lib'; + } +} + +use Test::More tests => 1; + +ok 1; diff --git a/cpan/Test-Harness/t/spool.t b/cpan/Test-Harness/t/spool.t new file mode 100644 index 0000000000..d22ffcdd77 --- /dev/null +++ b/cpan/Test-Harness/t/spool.t @@ -0,0 +1,139 @@ +#!/usr/bin/perl -w + +BEGIN { + unshift @INC, 't/lib'; +} + +# test T::H::_open_spool and _close_spool - these are good examples +# of the 'Fragile Test' pattern - messing with I/O primitives breaks +# nearly everything + +use strict; +use Test::More; + +my $useOrigOpen; +my $useOrigClose; + +# setup replacements for core open and close - breaking these makes everything very fragile +BEGIN { + $useOrigOpen = $useOrigClose = 1; + + # taken from http://www.perl.com/pub/a/2002/06/11/threads.html?page=2 + + *CORE::GLOBAL::open = \&my_open; + + sub my_open (*@) { + if ($useOrigOpen) { + if ( defined( $_[0] ) ) { + use Symbol qw(); + my $handle = Symbol::qualify( $_[0], (caller)[0] ); + no strict 'refs'; + if ( @_ == 1 ) { + return CORE::open($handle); + } + elsif ( @_ == 2 ) { + return CORE::open( $handle, $_[1] ); + } + else { + die "Can't open with more than two args"; + } + } + } + else { + return; + } + } + + *CORE::GLOBAL::close = sub (*) { + if ($useOrigClose) { return CORE::close(shift) } + else {return} + }; + +} + +use TAP::Harness; +use TAP::Parser; + +plan tests => 4; + +{ + + # coverage tests for the basically untested T::H::_open_spool + + my @spool = ( 't', 'spool' ); + $ENV{PERL_TEST_HARNESS_DUMP_TAP} = File::Spec->catfile(@spool); + +# now given that we're going to be writing stuff to the file system, make sure we have +# a cleanup hook + + END { + use File::Path; + + $useOrigOpen = $useOrigClose = 1; + + # remove the tree if we made it this far + rmtree( $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) + if $ENV{PERL_TEST_HARNESS_DUMP_TAP}; + } + + my @die; + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + # use the broken open + $useOrigOpen = 0; + + TAP::Harness->_open_spool( + File::Spec->catfile(qw (source_tests harness )) ); + + # restore universal sanity + $useOrigOpen = 1; + }; + + is @die, 1, 'open failed, die as expected'; + + my $spoolDir = quotemeta( + File::Spec->catfile( @spool, qw( source_tests harness ) ) ); + + like pop @die, qr/ Can't write $spoolDir \( /, '...with expected message'; + + # now make close fail + + use Symbol; + + my $spoolHandle = gensym; + + my $tap = <<'END_TAP'; +1..1 +ok 1 - input file opened + +END_TAP + + my $parser = TAP::Parser->new( + { spool => $spoolHandle, + stream => + TAP::Parser::IteratorFactory->new( [ split /\n/ => $tap ] ) + } + ); + + @die = (); + + eval { + local $SIG{__DIE__} = sub { push @die, @_ }; + + # use the broken CORE::close + $useOrigClose = 0; + + TAP::Harness->_close_spool($parser); + + $useOrigClose = 1; + }; + + unless ( is @die, 1, 'close failed, die as expected' ) { + diag " >>> $_ <<<\n" for @die; + } + + like pop @die, qr/ Error closing TAP spool file[(] /, + '...with expected message'; +} diff --git a/cpan/Test-Harness/t/state.t b/cpan/Test-Harness/t/state.t new file mode 100644 index 0000000000..2d94e9bbce --- /dev/null +++ b/cpan/Test-Harness/t/state.t @@ -0,0 +1,251 @@ +#!/usr/bin/perl -w + +BEGIN { + unshift @INC, 't/lib'; +} + +use strict; +use Test::More; +use App::Prove::State; +use App::Prove::State::Result; + +my @schedule = ( + { options => 'all', + get_tests_args => [], + expect => [ + 't/compat/env.t', + 't/compat/failure.t', + 't/compat/inc_taint.t', + 't/compat/version.t', + 't/source.t', + 't/yamlish-writer.t', + ], + }, + { options => 'failed', + get_tests_args => [], + expect => [ + 't/compat/inc_taint.t', + 't/compat/version.t', + ], + }, + { options => 'passed', + get_tests_args => [], + expect => [ + 't/compat/env.t', + 't/compat/failure.t', + 't/source.t', + 't/yamlish-writer.t', + ], + }, + { options => 'last', + get_tests_args => [], + expect => [ + 't/compat/env.t', + 't/compat/failure.t', + 't/compat/inc_taint.t', + 't/compat/version.t', + 't/source.t', + ], + }, + { options => 'todo', + get_tests_args => [], + expect => [ + 't/compat/version.t', + 't/compat/failure.t', + ], + + }, + { options => 'hot', + get_tests_args => [], + expect => [ + 't/compat/version.t', + 't/yamlish-writer.t', + 't/compat/env.t', + ], + }, + { options => 'adrian', + get_tests_args => [], + expect => [ + 't/compat/version.t', + 't/yamlish-writer.t', + 't/compat/env.t', + 't/compat/failure.t', + 't/compat/inc_taint.t', + 't/source.t', + ], + }, + { options => 'failed,passed', + get_tests_args => [], + expect => [ + 't/compat/inc_taint.t', + 't/compat/version.t', + 't/compat/env.t', + 't/compat/failure.t', + 't/source.t', + 't/yamlish-writer.t', + ], + }, + { options => [ 'failed', 'passed' ], + get_tests_args => [], + expect => [ + 't/compat/inc_taint.t', + 't/compat/version.t', + 't/compat/env.t', + 't/compat/failure.t', + 't/source.t', + 't/yamlish-writer.t', + ], + }, + { options => 'slow', + get_tests_args => [], + expect => [ + 't/yamlish-writer.t', + 't/compat/env.t', + 't/compat/inc_taint.t', + 't/compat/version.t', + 't/compat/failure.t', + 't/source.t', + ], + }, + { options => 'fast', + get_tests_args => [], + expect => [ + 't/source.t', + 't/compat/failure.t', + 't/compat/version.t', + 't/compat/inc_taint.t', + 't/compat/env.t', + 't/yamlish-writer.t', + ], + }, + { options => 'old', + get_tests_args => [], + expect => [ + 't/source.t', + 't/compat/inc_taint.t', + 't/compat/version.t', + 't/yamlish-writer.t', + 't/compat/failure.t', + 't/compat/env.t', + ], + }, + { options => 'new', + get_tests_args => [], + expect => [ + 't/compat/env.t', + 't/compat/failure.t', + 't/yamlish-writer.t', + 't/compat/version.t', + 't/compat/inc_taint.t', + 't/source.t', + ], + }, + { options => 'fresh', + get_tests_args => [], + expect => [ + 't/compat/env.t', + 't/compat/failure.t', + ], + }, +); + +plan tests => @schedule * 2; + +for my $test (@schedule) { + my $state = App::Prove::State->new; + isa_ok $state, 'App::Prove::State'; + + my $desc = $test->{options}; + + # Naughty + $state->{_} = get_state(); + my $options = $test->{options}; + $options = [$options] unless 'ARRAY' eq ref $options; + $state->apply_switch(@$options); + + my @got = $state->get_tests( @{ $test->{get_tests_args} } ); + my @expect = @{ $test->{expect} }; + unless ( is_deeply \@got, \@expect, "$desc: order OK" ) { + use Data::Dumper; + diag( Dumper( { got => \@got, want => \@expect } ) ); + } +} + +sub get_state { + return App::Prove::State::Result->new( + { generation => 51, + last_run_time => 1196285439, + tests => { + 't/compat/failure.t' => { + last_result => 0, + last_run_time => 1196371471.57738, + last_pass_time => 1196371471.57738, + total_passes => 48, + seq => 1549, + gen => 51, + elapsed => 0.1230, + last_todo => 1, + mtime => 1196285623, + }, + 't/yamlish-writer.t' => { + last_result => 0, + last_run_time => 1196371480.5761, + last_pass_time => 1196371480.5761, + last_fail_time => 1196368609, + total_passes => 41, + seq => 1578, + gen => 49, + elapsed => 12.2983, + last_todo => 0, + mtime => 1196285400, + }, + 't/compat/env.t' => { + last_result => 0, + last_run_time => 1196371471.42967, + last_pass_time => 1196371471.42967, + last_fail_time => 1196368608, + total_passes => 48, + seq => 1548, + gen => 52, + elapsed => 3.1290, + last_todo => 0, + mtime => 1196285739, + }, + 't/compat/version.t' => { + last_result => 2, + last_run_time => 1196371472.96476, + last_pass_time => 1196371472.96476, + last_fail_time => 1196368609, + total_passes => 47, + seq => 1555, + gen => 51, + elapsed => 0.2363, + last_todo => 4, + mtime => 1196285239, + }, + 't/compat/inc_taint.t' => { + last_result => 3, + last_run_time => 1196371471.89682, + last_pass_time => 1196371471.89682, + total_passes => 47, + seq => 1551, + gen => 51, + elapsed => 1.6938, + last_todo => 0, + mtime => 1196185639, + }, + 't/source.t' => { + last_result => 0, + last_run_time => 1196371479.72508, + last_pass_time => 1196371479.72508, + total_passes => 41, + seq => 1570, + gen => 51, + elapsed => 0.0143, + last_todo => 0, + mtime => 1186285639, + }, + } + } + ); +} diff --git a/cpan/Test-Harness/t/state_results.t b/cpan/Test-Harness/t/state_results.t new file mode 100644 index 0000000000..fe0b944333 --- /dev/null +++ b/cpan/Test-Harness/t/state_results.t @@ -0,0 +1,148 @@ +#!/usr/bin/perl -w + +BEGIN { + unshift @INC, 't/lib'; +} + +use strict; +use Test::More tests => 25; +use App::Prove::State; + +my $test_suite_data = test_suite_data(); + +# +# Test test suite results +# + +can_ok 'App::Prove::State::Result', 'new'; +isa_ok my $result = App::Prove::State::Result->new($test_suite_data), + 'App::Prove::State::Result', '... and the object it returns'; + +ok $result, 'state_version'; +ok defined $result->state_version, '... and it should be defined'; + +can_ok $result, 'generation'; +is $result->generation, $test_suite_data->{generation}, + '... and it should return the correct generation'; + +can_ok $result, 'num_tests'; +is $result->num_tests, scalar keys %{ $test_suite_data->{tests} }, + '... and it should return the number of tests run'; + +can_ok $result, 'raw'; +is_deeply $result->raw, $test_suite_data, + '... and it should return the raw, unblessed data'; + +# +# Check individual tests. +# + +can_ok $result, 'tests'; + +can_ok $result, 'test'; +eval { $result->test }; +my $error = $@; +like $error, qr/^\Qtest() requires a test name/, + '... and it should croak() if a test name is not supplied'; + +my $name = 't/compat/failure.t'; +ok my $test = $result->test('t/compat/failure.t'), + 'result() should succeed if the test name is found'; +isa_ok $test, 'App::Prove::State::Result::Test', + '... and the object it returns'; + +can_ok $test, 'name'; +is $test->name, $name, '... and it should return the test name'; + +can_ok $test, 'last_pass_time'; +like $test->last_pass_time, qr/^\d+\.\d+$/, + '... and it should return a numeric value'; + +can_ok $test, 'last_fail_time'; +ok !defined $test->last_fail_time, + '... and it should return undef if the test has never failed'; + +can_ok $result, 'remove'; +ok $result->remove($name), '... and calling it should succeed'; + +ok $test = $result->test($name), + '... and fetching the removed test should suceed'; +ok !defined $test->last_pass_time, '... and it should have clean values'; + +sub test_suite_data { + return { + 'version' => App::Prove::State::Result->state_version, + 'generation' => '51', + 'tests' => { + 't/compat/failure.t' => { + 'last_result' => '0', + 'last_run_time' => '1196371471.57738', + 'last_pass_time' => '1196371471.57738', + 'total_passes' => '48', + 'seq' => '1549', + 'gen' => '51', + 'elapsed' => 0.1230, + 'last_todo' => '1', + 'mtime' => 1196285623, + }, + 't/yamlish-writer.t' => { + 'last_result' => '0', + 'last_run_time' => '1196371480.5761', + 'last_pass_time' => '1196371480.5761', + 'last_fail_time' => '1196368609', + 'total_passes' => '41', + 'seq' => '1578', + 'gen' => '49', + 'elapsed' => 12.2983, + 'last_todo' => '0', + 'mtime' => 1196285400, + }, + 't/compat/env.t' => { + 'last_result' => '0', + 'last_run_time' => '1196371471.42967', + 'last_pass_time' => '1196371471.42967', + 'last_fail_time' => '1196368608', + 'total_passes' => '48', + 'seq' => '1548', + 'gen' => '52', + 'elapsed' => 3.1290, + 'last_todo' => '0', + 'mtime' => 1196285739, + }, + 't/compat/version.t' => { + 'last_result' => '2', + 'last_run_time' => '1196371472.96476', + 'last_pass_time' => '1196371472.96476', + 'last_fail_time' => '1196368609', + 'total_passes' => '47', + 'seq' => '1555', + 'gen' => '51', + 'elapsed' => 0.2363, + 'last_todo' => '4', + 'mtime' => 1196285239, + }, + 't/compat/inc_taint.t' => { + 'last_result' => '3', + 'last_run_time' => '1196371471.89682', + 'last_pass_time' => '1196371471.89682', + 'total_passes' => '47', + 'seq' => '1551', + 'gen' => '51', + 'elapsed' => 1.6938, + 'last_todo' => '0', + 'mtime' => 1196185639, + }, + 't/source.t' => { + 'last_result' => '0', + 'last_run_time' => '1196371479.72508', + 'last_pass_time' => '1196371479.72508', + 'total_passes' => '41', + 'seq' => '1570', + 'gen' => '51', + 'elapsed' => 0.0143, + 'last_todo' => '0', + 'mtime' => 1186285639, + }, + } + }; +} diff --git a/cpan/Test-Harness/t/streams.t b/cpan/Test-Harness/t/streams.t new file mode 100644 index 0000000000..b312ae8367 --- /dev/null +++ b/cpan/Test-Harness/t/streams.t @@ -0,0 +1,171 @@ +#!/usr/bin/perl -wT + +use strict; +use lib 't/lib'; + +use Test::More tests => 47; + +use TAP::Parser; +use TAP::Parser::IteratorFactory; + +my $STREAMED = 'TAP::Parser'; +my $ITER = 'TAP::Parser::Iterator'; +my $ITER_FH = "${ITER}::Stream"; +my $ITER_ARRAY = "${ITER}::Array"; + +my $factory = TAP::Parser::IteratorFactory->new; +my $stream = $factory->make_iterator( \*DATA ); +isa_ok $stream, 'TAP::Parser::Iterator'; +my $parser = TAP::Parser->new( { stream => $stream } ); +isa_ok $parser, 'TAP::Parser', + '... and creating a streamed parser should succeed'; + +can_ok $parser, '_stream'; +is ref $parser->_stream, $ITER_FH, + '... and it should return the proper iterator'; +can_ok $parser, 'next'; +is $parser->next->as_string, '1..5', + '... and the plan should parse correctly'; +is $parser->next->as_string, 'ok 1 - input file opened', + '... and the first test should parse correctly'; +is $parser->next->as_string, '... this is junk', + '... and junk should parse correctly'; +is $parser->next->as_string, + 'not ok 2 first line of the input valid # TODO some data', + '... and the second test should parse correctly'; +is $parser->next->as_string, '# this is a comment', + '... and comments should parse correctly'; +is $parser->next->as_string, 'ok 3 - read the rest of the file', + '... and the third test should parse correctly'; +is $parser->next->as_string, 'not ok 4 - this is a real failure', + '... and the fourth test should parse correctly'; +is $parser->next->as_string, 'ok 5 # SKIP we have no description', + '... and fifth test should parse correctly'; + +ok !$parser->parse_errors, '... and we should have no parse errors'; + +# plan at end + +my $tap = <<'END_TAP'; +ok 1 - input file opened +... this is junk +not ok first line of the input valid # todo some data +# this is a comment +ok 3 - read the rest of the file +not ok 4 - this is a real failure +ok 5 # skip we have no description +1..5 +END_TAP + +$stream = $factory->make_iterator( [ split /\n/ => $tap ] ); +ok $parser = TAP::Parser->new( { stream => $stream } ), + 'Now we create a parser with the plan at the end'; +isa_ok $parser->_stream, $ITER_ARRAY, + '... and now we should have an array iterator'; +is $parser->next->as_string, 'ok 1 - input file opened', + '... and the first test should parse correctly'; +is $parser->next->as_string, '... this is junk', + '... and junk should parse correctly'; +is $parser->next->as_string, + 'not ok 2 first line of the input valid # TODO some data', + '... and the second test should parse correctly'; +is $parser->next->as_string, '# this is a comment', + '... and comments should parse correctly'; +is $parser->next->as_string, 'ok 3 - read the rest of the file', + '... and the third test should parse correctly'; +is $parser->next->as_string, 'not ok 4 - this is a real failure', + '... and the fourth test should parse correctly'; +is $parser->next->as_string, 'ok 5 # SKIP we have no description', + '... and fifth test should parse correctly'; +is $parser->next->as_string, '1..5', + '... and the plan should parse correctly'; + +ok !$parser->parse_errors, '... and we should have no parse errors'; + +# misplaced plan (and one-off errors) + +$tap = <<'END_TAP'; +ok 1 - input file opened +1..5 +... this is junk +not ok first line of the input valid # todo some data +# this is a comment +ok 3 - read the rest of the file +not ok 4 - this is a real failure +ok 5 # skip we have no description +END_TAP + +$stream = $factory->make_iterator( [ split /\n/ => $tap ] ); + +ok $parser = TAP::Parser->new( { stream => $stream } ), + 'Now we create a parser with a plan as the second line'; +is $parser->next->as_string, 'ok 1 - input file opened', + '... and the first test should parse correctly'; +is $parser->next->as_string, '1..5', + '... and the plan should parse correctly'; +is $parser->next->as_string, '... this is junk', + '... and junk should parse correctly'; +is $parser->next->as_string, + 'not ok 2 first line of the input valid # TODO some data', + '... and the second test should parse correctly'; +is $parser->next->as_string, '# this is a comment', + '... and comments should parse correctly'; +is $parser->next->as_string, 'ok 3 - read the rest of the file', + '... and the third test should parse correctly'; +is $parser->next->as_string, 'not ok 4 - this is a real failure', + '... and the fourth test should parse correctly'; +is $parser->next->as_string, 'ok 5 # SKIP we have no description', + '... and fifth test should parse correctly'; + +ok $parser->parse_errors, '... and we should have one parse error'; +is + ( $parser->parse_errors )[0], + 'Plan (1..5) must be at the beginning or end of the TAP output', + '... telling us that our plan went awry'; + +$tap = <<'END_TAP'; +ok 1 - input file opened +... this is junk +not ok first line of the input valid # todo some data +# this is a comment +ok 3 - read the rest of the file +not ok 4 - this is a real failure +1..5 +ok 5 # skip we have no description +END_TAP + +$stream = $factory->make_iterator( [ split /\n/ => $tap ] ); + +ok $parser = TAP::Parser->new( { stream => $stream } ), + 'Now we create a parser with the plan as the second to last line'; +is $parser->next->as_string, 'ok 1 - input file opened', + '... and the first test should parse correctly'; +is $parser->next->as_string, '... this is junk', + '... and junk should parse correctly'; +is $parser->next->as_string, + 'not ok 2 first line of the input valid # TODO some data', + '... and the second test should parse correctly'; +is $parser->next->as_string, '# this is a comment', + '... and comments should parse correctly'; +is $parser->next->as_string, 'ok 3 - read the rest of the file', + '... and the third test should parse correctly'; +is $parser->next->as_string, 'not ok 4 - this is a real failure', + '... and the fourth test should parse correctly'; +is $parser->next->as_string, '1..5', + '... and the plan should parse correctly'; +is $parser->next->as_string, 'ok 5 # SKIP we have no description', + '... and fifth test should parse correctly'; + +ok $parser->parse_errors, '... and we should have one parse error'; +is + ( $parser->parse_errors )[0], + 'Plan (1..5) must be at the beginning or end of the TAP output', + '... telling us that our plan went awry'; + +__DATA__ +1..5 +ok 1 - input file opened +... this is junk +not ok first line of the input valid # todo some data +# this is a comment +ok 3 - read the rest of the file +not ok 4 - this is a real failure +ok 5 # skip we have no description diff --git a/cpan/Test-Harness/t/subclass_tests/non_perl_source b/cpan/Test-Harness/t/subclass_tests/non_perl_source new file mode 100644 index 0000000000..12f0f74012 --- /dev/null +++ b/cpan/Test-Harness/t/subclass_tests/non_perl_source @@ -0,0 +1,3 @@ +#!/bin/sh +echo "1..1" +echo "ok 1 - this is a test" diff --git a/cpan/Test-Harness/t/subclass_tests/perl_source b/cpan/Test-Harness/t/subclass_tests/perl_source new file mode 100644 index 0000000000..7fef7d5459 --- /dev/null +++ b/cpan/Test-Harness/t/subclass_tests/perl_source @@ -0,0 +1,6 @@ +#!/usr/bin/perl + +print <<'END_TESTS'; +1..1 +ok 1 - this is a test +END_TESTS diff --git a/cpan/Test-Harness/t/taint.t b/cpan/Test-Harness/t/taint.t new file mode 100644 index 0000000000..2812fc4375 --- /dev/null +++ b/cpan/Test-Harness/t/taint.t @@ -0,0 +1,49 @@ +#!/usr/bin/perl -w + +BEGIN { + unshift @INC, 't/lib'; +} + +# Test that options in PERL5OPT are propogated to tainted tests + +use strict; +use Test::More ( $^O eq 'VMS' ? ( skip_all => 'VMS' ) : ( tests => 1 ) ); + +use Config; +use TAP::Parser; + +my $lib_path = join( ', ', map "'$_'", grep !ref, grep defined, @INC ); + +sub run_test_file { + my ( $test_template, @args ) = @_; + + my $test_file = 'temp_test.tmp'; + + open TEST, ">$test_file" or die $!; + printf TEST $test_template, @args; + close TEST; + + my $p = TAP::Parser->new( + { source => $test_file, + + # Test taint when there's spaces in a -I path + switches => [q["-Ifoo bar"]], + } + ); + 1 while $p->next; + ok !$p->has_problems; + + unlink $test_file; +} + +{ + local $ENV{PERL5OPT} = $ENV{PERL_CORE} ? '-I../../lib -Mstrict' : '-Mstrict'; + run_test_file(<<'END'); +#!/usr/bin/perl -T + +print "1..1\n"; +print $INC{'strict.pm'} ? "ok 1\n" : "not ok 1\n"; +END +} + +1; diff --git a/cpan/Test-Harness/t/testargs.t b/cpan/Test-Harness/t/testargs.t new file mode 100644 index 0000000000..aa3aa7337c --- /dev/null +++ b/cpan/Test-Harness/t/testargs.t @@ -0,0 +1,128 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; + +use Test::More tests => 19; +use File::Spec; +use TAP::Parser; +use TAP::Harness; +use App::Prove; + +my $test = File::Spec->catfile( + 't', + 'sample-tests', + 'echo' +); + +diag( "\n\n", bigness( join ' ', @ARGV ), "\n\n" ) if @ARGV; + +sub echo_ok { + my $options = shift; + my @args = @_; + my $parser = TAP::Parser->new( { %$options, test_args => \@args } ); + my @got = (); + while ( my $result = $parser->next ) { + push @got, $result; + } + my $plan = shift @got; + ok $plan->is_plan; + for (@got) { + is $_->description, shift(@args), + join( ', ', keys %$options ) . ": option passed OK"; + } +} + +for my $args ( [qw( yes no maybe )], [qw( 1 2 3 )] ) { + echo_ok( { source => $test }, @$args ); + echo_ok( { exec => [ $^X, $test ] }, @$args ); +} + +{ + my $harness = TAP::Harness->new( + { verbosity => -9, test_args => [qw( magic hat brigade )] } ); + my $aggregate = $harness->runtests($test); + + is $aggregate->total, 3, "ran the right number of tests"; + is $aggregate->passed, 3, "and they passed"; +} + +package Test::Prove; + +use vars qw(@ISA); +@ISA = 'App::Prove'; + +sub _runtests { + my $self = shift; + push @{ $self->{_log} }, [@_]; + return; +} + +sub get_run_log { + my $self = shift; + return $self->{_log}; +} + +package main; + +{ + my $app = Test::Prove->new; + + $app->process_args( '--norc', $test, '::', 'one', 'two', 'huh' ); + $app->run(); + my $log = $app->get_run_log; + is_deeply $log->[0]->[0]->{test_args}, [ 'one', 'two', 'huh' ], + "prove args match"; +} + +sub bigness { + my $str = join '', @_; + my @cdef = ( + '0000000000000000', '1818181818001800', '6c6c6c0000000000', + '36367f367f363600', '0c3f683e0b7e1800', '60660c1830660600', + '386c6c386d663b00', '0c18300000000000', '0c18303030180c00', + '30180c0c0c183000', '00187e3c7e180000', '0018187e18180000', + '0000000000181830', '0000007e00000000', '0000000000181800', + '00060c1830600000', '3c666e7e76663c00', '1838181818187e00', + '3c66060c18307e00', '3c66061c06663c00', '0c1c3c6c7e0c0c00', + '7e607c0606663c00', '1c30607c66663c00', '7e060c1830303000', + '3c66663c66663c00', '3c66663e060c3800', '0000181800181800', + '0000181800181830', '0c18306030180c00', '00007e007e000000', + '30180c060c183000', '3c660c1818001800', '3c666e6a6e603c00', + '3c66667e66666600', '7c66667c66667c00', '3c66606060663c00', + '786c6666666c7800', '7e60607c60607e00', '7e60607c60606000', + '3c66606e66663c00', '6666667e66666600', '7e18181818187e00', + '3e0c0c0c0c6c3800', '666c7870786c6600', '6060606060607e00', + '63777f6b6b636300', '6666767e6e666600', '3c66666666663c00', + '7c66667c60606000', '3c6666666a6c3600', '7c66667c6c666600', + '3c66603c06663c00', '7e18181818181800', '6666666666663c00', + '66666666663c1800', '63636b6b7f776300', '66663c183c666600', + '6666663c18181800', '7e060c1830607e00', '7c60606060607c00', + '006030180c060000', '3e06060606063e00', '183c664200000000', + '00000000000000ff', '1c36307c30307e00', '00003c063e663e00', + '60607c6666667c00', '00003c6660663c00', '06063e6666663e00', + '00003c667e603c00', '1c30307c30303000', '00003e66663e063c', + '60607c6666666600', '1800381818183c00', '1800381818181870', + '6060666c786c6600', '3818181818183c00', '0000367f6b6b6300', + '00007c6666666600', '00003c6666663c00', '00007c66667c6060', + '00003e66663e0607', '00006c7660606000', '00003e603c067c00', + '30307c3030301c00', '0000666666663e00', '00006666663c1800', + '0000636b6b7f3600', '0000663c183c6600', '00006666663e063c', + '00007e0c18307e00', '0c18187018180c00', '1818180018181800', + '3018180e18183000', '316b460000000000' + ); + my @chars = unpack( 'C*', $str ); + my @out = (); + for my $row ( 0 .. 7 ) { + for my $char (@chars) { + next if $char < 32 || $char > 126; + my $size = scalar(@cdef); + my $byte = hex( substr( $cdef[ $char - 32 ], $row * 2, 2 ) ); + my $bits = sprintf( '%08b', $byte ); + $bits =~ tr/01/ #/; + push @out, $bits; + } + push @out, "\n"; + } + return join '', @out; +} diff --git a/cpan/Test-Harness/t/unicode.t b/cpan/Test-Harness/t/unicode.t new file mode 100644 index 0000000000..88d32081ba --- /dev/null +++ b/cpan/Test-Harness/t/unicode.t @@ -0,0 +1,125 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; +use Test::More; +use TAP::Parser; + +my @schedule; +my %make_test; + +BEGIN { + + # TODO: Investigate failure on 5.8.0 + plan skip_all => "unicode on Perl <= 5.8.0" + unless $] > 5.008; + + plan skip_all => "PERL_UNICODE set" + if defined $ENV{PERL_UNICODE}; + + eval "use File::Temp"; + plan skip_all => "File::Temp unavailable" + if $@; + + eval "use Encode"; + plan skip_all => "Encode unavailable" + if $@; + + # Subs that take the supplied TAP and turn it into a set of args to + # supply to TAP::Harness->new. The returned hash includes the + # temporary file so that its reference count doesn't go to zero + # until we're finished with it. + %make_test = ( + file => sub { + my $source = shift; + my $tmp = File::Temp->new; + open my $fh, ">$tmp" or die "Can't write $tmp ($!)\n"; + eval 'binmode( $fh, ":utf8" )'; + print $fh join( "\n", @$source ), "\n"; + close $fh; + + open my $taph, "<$tmp" or die "Can't read $tmp ($!)\n"; + eval 'binmode( $taph, ":utf8" )'; + return { + temp => $tmp, + args => { source => $taph }, + }; + }, + script => sub { + my $source = shift; + my $tmp = File::Temp->new; + open my $fh, ">$tmp" or die "Can't write $tmp ($!)\n"; + eval 'binmode( $fh, ":utf8" )'; + print $fh map {"print qq{$_\\n};\n"} @$source; + close $fh; + + open my $taph, "<$tmp" or die "Can't read $tmp ($!)\n"; + return { + temp => $tmp, + args => { exec => [ $^X, "$tmp" ] }, + }; + }, + ); + + @schedule = ( + { name => 'Non-unicode warm up', + source => [ + 'TAP version 13', + '1..1', + 'ok 1 Everything is fine', + ], + expect => [ + { isa => 'TAP::Parser::Result::Version', }, + { isa => 'TAP::Parser::Result::Plan', }, + { isa => 'TAP::Parser::Result::Test', + description => "Everything is fine" + }, + ], + }, + { name => 'Unicode smiley', + source => [ + 'TAP version 13', + '1..1', + + # Funky quoting / eval to avoid errors on older Perls + eval qq{"ok 1 Everything is fine \\x{263a}"}, + ], + expect => [ + { isa => 'TAP::Parser::Result::Version', }, + { isa => 'TAP::Parser::Result::Plan', }, + { isa => 'TAP::Parser::Result::Test', + description => eval qq{"Everything is fine \\x{263a}"} + }, + ], + } + ); + + plan 'no_plan'; +} + +for my $test (@schedule) { + for my $type ( sort keys %make_test ) { + my $name = sprintf( "%s (%s)", $test->{name}, $type ); + my $args = $make_test{$type}->( $test->{source} ); + + my $parser = TAP::Parser->new( $args->{args} ); + isa_ok $parser, 'TAP::Parser'; + my @expect = @{ $test->{expect} }; + while ( my $tok = $parser->next ) { + my $exp = shift @expect; + for my $item ( sort keys %$exp ) { + my $val = $exp->{$item}; + if ( 'isa' eq $item ) { + isa_ok $tok, $val; + } + elsif ( 'CODE' eq ref $val ) { + ok $val->($tok), "$name: assertion for $item"; + } + else { + my $got = $tok->$item(); + is $got, $val, "$name: value for $item matches"; + } + } + } + } +} diff --git a/cpan/Test-Harness/t/utils.t b/cpan/Test-Harness/t/utils.t new file mode 100644 index 0000000000..4851ac1f1c --- /dev/null +++ b/cpan/Test-Harness/t/utils.t @@ -0,0 +1,61 @@ +#!/usr/bin/perl -w + +use strict; +use lib 't/lib'; + +use TAP::Parser::Utils qw( split_shell ); +use Test::More; + +my @schedule = ( + { name => 'Bare words', + in => 'bare words are here', + out => [ 'bare', 'words', 'are', 'here' ], + }, + { name => 'Single quotes', + in => "'bare' 'words' 'are' 'here'", + out => [ 'bare', 'words', 'are', 'here' ], + }, + { name => 'Double quotes', + in => '"bare" "words" "are" "here"', + out => [ 'bare', 'words', 'are', 'here' ], + }, + { name => 'Escapes', + in => '\ "ba\"re" \'wo\\\'rds\' \\\\"are" "here"', + out => [ ' ', 'ba"re', "wo'rds", '\\are', 'here' ], + }, + { name => 'Flag', + in => '-e "system(shift)"', + out => [ '-e', 'system(shift)' ], + }, + { name => 'Nada', + in => undef, + out => [], + }, + { name => 'Nada II', + in => '', + out => [], + }, + { name => 'Zero', + in => 0, + out => ['0'], + }, + { name => 'Empty', + in => '""', + out => [''], + }, + { name => 'Empty II', + in => "''", + out => [''], + }, +); + +plan tests => 1 * @schedule; + +for my $test (@schedule) { + my $name = $test->{name}; + my @got = split_shell( $test->{in} ); + unless ( is_deeply \@got, $test->{out}, "$name: parse OK" ) { + use Data::Dumper; + diag( Dumper( { want => $test->{out}, got => \@got } ) ); + } +} diff --git a/cpan/Test-Harness/t/yamlish-output.t b/cpan/Test-Harness/t/yamlish-output.t new file mode 100644 index 0000000000..914d7ea237 --- /dev/null +++ b/cpan/Test-Harness/t/yamlish-output.t @@ -0,0 +1,100 @@ +#!/usr/bin/perl -wT + +use strict; +use lib 't/lib'; + +use Test::More tests => 9; + +use TAP::Parser::YAMLish::Writer; + +my $out = [ + "---", + "bill-to:", + " address:", + " city: \"Royal Oak\"", + " lines: \"458 Walkman Dr.\\nSuite #292\\n\"", + " postal: 48046", + " state: MI", + " family: Dumars", + " given: Chris", + "comments: \"Late afternoon is best. Backup contact is Nancy Billsmer \@ 338-4338\\n\"", + "date: 2001-01-23", + "invoice: 34843", + "product:", + " -", + " description: Basketball", + " price: 450.00", + " quantity: 4", + " sku: BL394D", + " -", + " description: \"Super Hoop\"", + " price: 2392.00", + " quantity: 1", + " sku: BL4438H", + "tax: 251.42", + "total: 4443.52", + "...", +]; + +my $in = { + 'bill-to' => { + 'given' => 'Chris', + 'address' => { + 'city' => 'Royal Oak', + 'postal' => '48046', + 'lines' => "458 Walkman Dr.\nSuite #292\n", + 'state' => 'MI' + }, + 'family' => 'Dumars' + }, + 'invoice' => '34843', + 'date' => '2001-01-23', + 'tax' => '251.42', + 'product' => [ + { 'sku' => 'BL394D', + 'quantity' => '4', + 'price' => '450.00', + 'description' => 'Basketball' + }, + { 'sku' => 'BL4438H', + 'quantity' => '1', + 'price' => '2392.00', + 'description' => 'Super Hoop' + } + ], + 'comments' => + "Late afternoon is best. Backup contact is Nancy Billsmer @ 338-4338\n", + 'total' => '4443.52' +}; + +my @buf1 = (); +my @buf2 = (); +my $buf3 = ''; + +my @destination = ( + { name => 'Array reference', + destination => \@buf1, + normalise => sub { return \@buf1 }, + }, + { name => 'Closure', + destination => sub { push @buf2, shift }, + normalise => sub { return \@buf2 }, + }, + { name => 'Scalar', + destination => \$buf3, + normalise => sub { + my @ar = split( /\n/, $buf3 ); + return \@ar; + }, + }, +); + +for my $dest (@destination) { + my $name = $dest->{name}; + ok my $yaml = TAP::Parser::YAMLish::Writer->new, "$name: Created"; + isa_ok $yaml, 'TAP::Parser::YAMLish::Writer'; + + $yaml->write( $in, $dest->{destination} ); + my $got = $dest->{normalise}->(); + is_deeply $got, $out, "$name: Result matches"; +} diff --git a/cpan/Test-Harness/t/yamlish-writer.t b/cpan/Test-Harness/t/yamlish-writer.t new file mode 100644 index 0000000000..f7a22c3dab --- /dev/null +++ b/cpan/Test-Harness/t/yamlish-writer.t @@ -0,0 +1,274 @@ +#!/usr/bin/perl + +use strict; +use lib 't/lib'; + +use Test::More; + +use TAP::Parser::YAMLish::Reader; +use TAP::Parser::YAMLish::Writer; + +my @SCHEDULE; + +BEGIN { + @SCHEDULE = ( + { name => 'Simple scalar', + in => 1, + out => [ + '--- 1', + '...', + ], + }, + { name => 'Undef', + in => undef, + out => [ + '--- ~', + '...', + ], + }, + { name => 'Unprintable', + in => "\x01\n\t", + out => [ + '--- "\x01\n\t"', + '...', + ], + }, + { name => 'Simple array', + in => [ 1, 2, 3 ], + out => [ + '---', + '- 1', + '- 2', + '- 3', + '...', + ], + }, + { name => 'Empty array', + in => [], + out => [ + '--- []', + '...' + ], + }, + { name => 'Empty hash', + in => {}, + out => [ + '--- {}', + '...' + ], + }, + { name => 'Array, two elements, undef', + in => [ undef, undef ], + out => [ + '---', + '- ~', + '- ~', + '...', + ], + }, + { name => 'Nested array', + in => [ 1, 2, [ 3, 4 ], 5 ], + out => [ + '---', + '- 1', + '- 2', + '-', + ' - 3', + ' - 4', + '- 5', + '...', + ], + }, + { name => 'Nested empty', + in => [ 1, 2, [], 5 ], + out => [ + '---', + '- 1', + '- 2', + '- []', + '- 5', + '...', + ], + }, + { name => 'Simple hash', + in => { one => '1', two => '2', three => '3' }, + out => [ + '---', + 'one: 1', + 'three: 3', + 'two: 2', + '...', + ], + }, + { name => 'Nested hash', + in => { + one => '1', two => '2', + more => { three => '3', four => '4' } + }, + out => [ + '---', + 'more:', + ' four: 4', + ' three: 3', + 'one: 1', + 'two: 2', + '...', + ], + }, + { name => 'Nested empty', + in => { one => '1', two => '2', more => {} }, + out => [ + '---', + 'more: {}', + 'one: 1', + 'two: 2', + '...', + ], + }, + { name => 'Unprintable key', + in => { one => '1', "\x02" => '2', three => '3' }, + out => [ + '---', + '"\x02": 2', + 'one: 1', + 'three: 3', + '...', + ], + }, + { name => 'Empty key', + in => { '' => 'empty' }, + out => [ + '---', + "'': empty", + '...', + ], + }, + { name => 'Empty value', + in => { '' => '' }, + out => [ + '---', + "'': ''", + '...', + ], + }, + { name => 'Funky hash key', + in => { './frob' => 'is_frob' }, + out => [ + '---', + '"./frob": is_frob', + '...', + ] + }, + { name => 'Complex', + in => { + 'bill-to' => { + 'given' => 'Chris', + 'address' => { + 'city' => 'Royal Oak', + 'postal' => '48046', + 'lines' => "458 Walkman Dr.\nSuite #292\n", + 'state' => 'MI' + }, + 'family' => 'Dumars' + }, + 'invoice' => '34843', + 'date' => '2001-01-23', + 'tax' => '251.42', + 'product' => [ + { 'sku' => 'BL394D', + 'quantity' => '4', + 'price' => '450.00', + 'description' => 'Basketball' + }, + { 'sku' => 'BL4438H', + 'quantity' => '1', + 'price' => '2392.00', + 'description' => 'Super Hoop' + } + ], + 'comments' => + "Late afternoon is best. Backup contact is Nancy Billsmer @ 338-4338\n", + 'total' => '4443.52' + }, + out => [ + "---", + "bill-to:", + " address:", + " city: \"Royal Oak\"", + " lines: \"458 Walkman Dr.\\nSuite #292\\n\"", + " postal: 48046", + " state: MI", + " family: Dumars", + " given: Chris", + "comments: \"Late afternoon is best. Backup contact is Nancy Billsmer \@ 338-4338\\n\"", + "date: 2001-01-23", + "invoice: 34843", + "product:", + " -", + " description: Basketball", + " price: 450.00", + " quantity: 4", + " sku: BL394D", + " -", + " description: \"Super Hoop\"", + " price: 2392.00", + " quantity: 1", + " sku: BL4438H", + "tax: 251.42", + "total: 4443.52", + "...", + ], + }, + ); + + plan tests => @SCHEDULE * 6; +} + +sub iter { + my $ar = shift; + return sub { + return shift @$ar; + }; +} + +for my $test (@SCHEDULE) { + my $name = $test->{name}; + ok my $yaml = TAP::Parser::YAMLish::Writer->new, "$name: Created"; + isa_ok $yaml, 'TAP::Parser::YAMLish::Writer'; + + my $got = []; + my $writer = sub { push @$got, shift }; + + my $data = $test->{in}; + + eval { $yaml->write( $data, $writer ) }; + + if ( my $err = $test->{error} ) { + unless ( like $@, $err, "$name: Error message" ) { + diag "Error: $@\n"; + } + is_deeply $got, [], "$name: No result"; + pass; + } + else { + my $want = $test->{out}; + unless ( ok !$@, "$name: No error" ) { + diag "Error: $@\n"; + } + unless ( is_deeply $got, $want, "$name: Result matches" ) { + use Data::Dumper; + diag Dumper($got); + diag Dumper($want); + } + + my $yr = TAP::Parser::YAMLish::Reader->new; + + # Now try parsing it + my $reader = sub { shift @$got }; + my $parsed = eval { $yr->read($reader) }; + ok !$@, "$name: no error" or diag "$@"; + + is_deeply $parsed, $data, "$name: Reparse OK"; + } +} + diff --git a/cpan/Test-Harness/t/yamlish.t b/cpan/Test-Harness/t/yamlish.t new file mode 100644 index 0000000000..76ba7982b4 --- /dev/null +++ b/cpan/Test-Harness/t/yamlish.t @@ -0,0 +1,529 @@ +#!perl -w + +use strict; +use lib 't/lib'; + +use Test::More; + +use TAP::Parser::YAMLish::Reader; + +my @SCHEDULE; + +BEGIN { + @SCHEDULE = ( + { name => 'Hello World', + in => [ + '--- Hello, World', + '...', + ], + out => "Hello, World", + }, + { name => 'Hello World 2', + in => [ + '--- \'Hello, \'\'World\'', + '...', + ], + out => "Hello, 'World", + }, + { name => 'Hello World 3', + in => [ + '--- "Hello, World"', + '...', + ], + out => "Hello, World", + }, + { name => 'Hello World 4', + in => [ + '--- "Hello, World"', + '...', + ], + out => "Hello, World", + }, + { name => 'Hello World 4', + in => [ + '--- >', + ' Hello,', + ' World', + '...', + ], + out => "Hello, World\n", + }, + { name => 'Hello World Block', + in => [ + '--- |', + ' Hello,', + ' World', + '...', + ], + out => "Hello,\n World\n", + }, + { name => 'Hello World 5', + in => [ + '--- >', + ' Hello,', + ' World', + '...', + ], + error => qr{Missing\s+'[.][.][.]'}, + }, + { name => 'Simple array', + in => [ + '---', + '- 1', + '- 2', + '- 3', + '...', + ], + out => [ '1', '2', '3' ], + }, + { name => 'Mixed array', + in => [ + '---', + '- 1', + '- \'two\'', + '- "three\n"', + '...', + ], + out => [ '1', 'two', "three\n" ], + }, + { name => 'Hash in array', + in => [ + '---', + '- 1', + '- two: 2', + '- 3', + '...', + ], + out => [ '1', { two => '2' }, '3' ], + }, + { name => 'Hash in array 2', + in => [ + '---', + '- 1', + '- two: 2', + ' three: 3', + '- 4', + '...', + ], + out => [ '1', { two => '2', three => '3' }, '4' ], + }, + { name => 'Nested array', + in => [ + '---', + '- one', + '-', + ' - two', + ' -', + ' - three', + ' - four', + '- five', + '...', + ], + out => [ 'one', [ 'two', ['three'], 'four' ], 'five' ], + }, + { name => 'Nested hash', + in => [ + '---', + 'one:', + ' five: 5', + ' two:', + ' four: 4', + ' three: 3', + 'six: 6', + '...', + ], + out => { + one => { two => { three => '3', four => '4' }, five => '5' }, + six => '6' + }, + }, + { name => 'Space after colon', + in => [ '---', 'spog: ', ' - 1', ' - 2', '...' ], + out => { spog => [ 1, 2 ] }, + }, + { name => 'Original YAML::Tiny test', + in => [ + '---', + 'invoice: 34843', + 'date : 2001-01-23', + 'bill-to:', + ' given : Chris', + ' family : Dumars', + ' address:', + ' lines: |', + ' 458 Walkman Dr.', + ' Suite #292', + ' city : Royal Oak', + ' state : MI', + ' postal : 48046', + 'product:', + ' - sku : BL394D', + ' quantity : 4', + ' description : Basketball', + ' price : 450.00', + ' - sku : BL4438H', + ' quantity : 1', + ' description : Super Hoop', + ' price : 2392.00', + 'tax : 251.42', + 'total: 4443.52', + 'comments: >', + ' Late afternoon is best.', + ' Backup contact is Nancy', + ' Billsmer @ 338-4338', + '...', + ], + out => { + 'bill-to' => { + 'given' => 'Chris', + 'address' => { + 'city' => 'Royal Oak', + 'postal' => '48046', + 'lines' => "458 Walkman Dr.\nSuite #292\n", + 'state' => 'MI' + }, + 'family' => 'Dumars' + }, + 'invoice' => '34843', + 'date' => '2001-01-23', + 'tax' => '251.42', + 'product' => [ + { 'sku' => 'BL394D', + 'quantity' => '4', + 'price' => '450.00', + 'description' => 'Basketball' + }, + { 'sku' => 'BL4438H', + 'quantity' => '1', + 'price' => '2392.00', + 'description' => 'Super Hoop' + } + ], + 'comments' => + "Late afternoon is best. Backup contact is Nancy Billsmer @ 338-4338\n", + 'total' => '4443.52' + } + }, + + # Tests harvested from YAML::Tiny + { in => ['...'], + name => 'Regression: empty', + error => qr{document\s+header\s+not\s+found} + }, + { in => [ + '# comment', + '...' + ], + name => 'Regression: only_comment', + error => qr{document\s+header\s+not\s+found} + }, + { out => undef, + in => [ + '---', + '...' + ], + name => 'Regression: only_header', + error => qr{Premature\s+end}i, + }, + { out => undef, + in => [ + '---', + '---', + '...' + ], + name => 'Regression: two_header', + error => qr{Unexpected\s+start}i, + }, + { out => undef, + in => [ + '--- ~', + '...' + ], + name => 'Regression: one_undef' + }, + { out => undef, + in => [ + '--- ~', + '...' + ], + name => 'Regression: one_undef2' + }, + { in => [ + '--- ~', + '---', + '...' + ], + name => 'Regression: two_undef', + error => qr{Missing\s+'[.][.][.]'}, + }, + { out => 'foo', + in => [ + '--- foo', + '...' + ], + name => 'Regression: one_scalar', + }, + { out => 'foo', + in => [ + '--- foo', + '...' + ], + name => 'Regression: one_scalar2', + }, + { in => [ + '--- foo', + '--- bar', + '...' + ], + name => 'Regression: two_scalar', + error => qr{Missing\s+'[.][.][.]'}, + }, + { out => ['foo'], + in => [ + '---', + '- foo', + '...' + ], + name => 'Regression: one_list1' + }, + { out => [ + 'foo', + 'bar' + ], + in => [ + '---', + '- foo', + '- bar', + '...' + ], + name => 'Regression: one_list2' + }, + { out => [ + undef, + 'bar' + ], + in => [ + '---', + '- ~', + '- bar', + '...' + ], + name => 'Regression: one_listundef' + }, + { out => { 'foo' => 'bar' }, + in => [ + '---', + 'foo: bar', + '...' + ], + name => 'Regression: one_hash1' + }, + { out => { + 'foo' => 'bar', + 'this' => undef + }, + in => [ + '---', + 'foo: bar', + 'this: ~', + '...' + ], + name => 'Regression: one_hash2' + }, + { out => { + 'foo' => [ + 'bar', + undef, + 'baz' + ] + }, + in => [ + '---', + 'foo:', + ' - bar', + ' - ~', + ' - baz', + '...' + ], + name => 'Regression: array_in_hash' + }, + { out => { + 'bar' => { 'foo' => 'bar' }, + 'foo' => undef + }, + in => [ + '---', + 'foo: ~', + 'bar:', + ' foo: bar', + '...' + ], + name => 'Regression: hash_in_hash' + }, + { out => [ + { 'foo' => undef, + 'this' => 'that' + }, + 'foo', undef, + { 'foo' => 'bar', + 'this' => 'that' + } + ], + in => [ + '---', + '-', + ' foo: ~', + ' this: that', + '- foo', + '- ~', + '-', + ' foo: bar', + ' this: that', + '...' + ], + name => 'Regression: hash_in_array' + }, + { out => ['foo'], + in => [ + '---', + '- \'foo\'', + '...' + ], + name => 'Regression: single_quote1' + }, + { out => [' '], + in => [ + '---', + '- \' \'', + '...' + ], + name => 'Regression: single_spaces' + }, + { out => [''], + in => [ + '---', + '- \'\'', + '...' + ], + name => 'Regression: single_null' + }, + { out => ' ', + in => [ + '--- " "', + '...' + ], + name => 'Regression: only_spaces' + }, + { out => [ + undef, + { 'foo' => 'bar', + 'this' => 'that' + }, + 'baz' + ], + in => [ + '---', + '- ~', + '- foo: bar', + ' this: that', + '- baz', + '...' + ], + name => 'Regression: inline_nested_hash' + }, + { name => "Unprintables", + in => [ + "---", + "- \"\\z\\x01\\x02\\x03\\x04\\x05\\x06\\a\\x08\\t\\n\\v\\f\\r\\x0e\\x0f\"", + "- \"\\x10\\x11\\x12\\x13\\x14\\x15\\x16\\x17\\x18\\x19\\x1a\\e\\x1c\\x1d\\x1e\\x1f\"", + "- \" !\\\"#\$%&'()*+,-./\"", + "- 0123456789:;<=>?", + "- '\@ABCDEFGHIJKLMNO'", + "- 'PQRSTUVWXYZ[\\]^_'", + "- '`abcdefghijklmno'", + "- 'pqrstuvwxyz{|}~\177'", + "- \200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217", + "- \220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237", + "- \240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257", + "- \260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277", + "- \300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317", + "- \320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337", + "- \340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357", + "- \360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377", + "..." + ], + out => [ + "\0\1\2\3\4\5\6\a\b\t\n\13\f\r\16\17", + "\20\21\22\23\24\25\26\27\30\31\32\e\34\35\36\37", + " !\"#\$%&'()*+,-./", + "0123456789:;<=>?", + "\@ABCDEFGHIJKLMNO", + "PQRSTUVWXYZ[\\]^_", + "`abcdefghijklmno", + "pqrstuvwxyz{|}~\177", + "\200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217", + "\220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237", + "\240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257", + "\260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277", + "\300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317", + "\320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337", + "\340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357", + "\360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377" + ], + }, + { name => 'Quoted hash keys', + in => [ + '---', + ' "quoted": Magic!', + ' "\n\t": newline, tab', + '...', + ], + out => { + quoted => 'Magic!', + "\n\t" => 'newline, tab', + }, + }, + { name => 'Empty', + in => [], + out => undef, + }, + ); + + plan tests => @SCHEDULE * 5; +} + +sub iter { + my $ar = shift; + return sub { + return shift @$ar; + }; +} + +for my $test (@SCHEDULE) { + my $name = $test->{name}; + ok my $yaml = TAP::Parser::YAMLish::Reader->new, "$name: Created"; + isa_ok $yaml, 'TAP::Parser::YAMLish::Reader'; + + my $source = join( "\n", @{ $test->{in} } ) . "\n"; + + my $iter = iter( $test->{in} ); + my $got = eval { $yaml->read($iter) }; + + my $raw = $yaml->get_raw; + + if ( my $err = $test->{error} ) { + unless ( like $@, $err, "$name: Error message" ) { + diag "Error: $@\n"; + } + ok !$got, "$name: No result"; + pass; + } + else { + my $want = $test->{out}; + unless ( ok !$@, "$name: No error" ) { + diag "Error: $@\n"; + } + is_deeply $got, $want, "$name: Result matches"; + is $raw, $source, "$name: Captured source matches"; + } +} |