diff options
Diffstat (limited to 'cpan/Test-Harness/t/results.t')
| -rw-r--r-- | cpan/Test-Harness/t/results.t | 295 |
1 files changed, 295 insertions, 0 deletions
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"; + } +} |