From: Vincent Pit Date: Wed, 29 Dec 2010 16:17:47 +0000 (+0100) Subject: Fall back to Test::More when PERL_TEST_LEANER_USES_TEST_MORE is set X-Git-Tag: v0.02~3 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=653bd706f7c17c61e34d98e6fcaed75861b2f7d7;p=perl%2Fmodules%2FTest-Leaner.git Fall back to Test::More when PERL_TEST_LEANER_USES_TEST_MORE is set --- diff --git a/MANIFEST b/MANIFEST index 734c6e9..7b33b2e 100644 --- a/MANIFEST +++ b/MANIFEST @@ -7,6 +7,7 @@ lib/Test/Leaner.pm samples/bench.pl t/00-load.t t/01-import.t +t/02-fallback.t t/05-pass.t t/06-fail.t t/07-BAIL_OUT.t diff --git a/lib/Test/Leaner.pm b/lib/Test/Leaner.pm index bc684ec..6f90cef 100644 --- a/lib/Test/Leaner.pm +++ b/lib/Test/Leaner.pm @@ -98,6 +98,119 @@ my ($TAP_STREAM, $DIAG_STREAM); my ($plan, $test, $failed, $no_diag, $done_testing); +our @EXPORT = qw< + plan + skip + done_testing + pass + fail + ok + is + isnt + like + unlike + cmp_ok + is_deeply + diag + note + BAIL_OUT +>; + +=head1 ENVIRONMENT + +=head2 C + +If this environment variable is set, L will replace its functions by those from L. +Moreover, the symbols that are imported you C will be those from L, but you can still only import the symbols originally defined in L (hence the functions from L that are not implemented in L will not be imported). +If your version of L is too old and doesn't have some symbols (like L or L), they will be replaced in L by croaking stubs. + +This may be useful if your L-based test script fails and you want extra diagnostics. + +=cut + +sub _handle_import_args { + my @imports; + + my $i = 0; + while ($i <= $#_) { + my $item = $_[$i]; + my $splice; + if (defined $item) { + if ($item eq 'import') { + push @imports, @{ $_[$i+1] }; + $splice = 2; + } elsif ($item eq 'no_diag') { + lock $plan if THREADSAFE; + $no_diag = 1; + $splice = 1; + } + } + if ($splice) { + splice @_, $i, $splice; + } else { + ++$i; + } + } + + return @imports; +} + +if ($ENV{PERL_TEST_LEANER_USES_TEST_MORE}) { + require Test::More; + + my $leaner_stash = \%Test::Leaner::; + my $more_stash = \%Test::More::; + + my %valid_imports; + + for (@EXPORT) { + my $replacement = exists $more_stash->{$_} ? *{$more_stash->{$_}}{CODE} + : undef; + if (defined $replacement) { + $valid_imports{$_} = 1; + } else { + $replacement = sub { + @_ = ("$_ is not implemented in this version of Test::More"); + goto &croak; + }; + } + no warnings 'redefine'; + $leaner_stash->{$_} = $replacement; + } + + my $import = sub { + shift; + my @imports = &_handle_import_args; + @imports = @EXPORT unless @imports; + my @test_more_imports; + for (@imports) { + if ($valid_imports{$_}) { + push @test_more_imports, $_; + } else { + my $pkg = caller; + no strict 'refs'; + *{$pkg."::$_"} = $leaner_stash->{$_}; + } + } + my $test_more_import = 'Test::More'->can('import'); + @_ = ( + 'Test::More', + @_, + import => \@test_more_imports, + ); + { + lock $plan if THREADSAFE; + push @_, 'no_diag' if $no_diag; + } + goto $test_more_import; + }; + + no warnings 'redefine'; + *import = $import; + + return 1; +} + sub NO_PLAN () { -1 } sub SKIP_ALL () { -2 } @@ -115,13 +228,21 @@ BEGIN { sub carp { my $level = 1 + ($Test::Builder::Level || 0); - my ($file, $line) = (caller $level)[1, 2]; + my @caller; + do { + @caller = caller $level--; + } while (!@caller and $level >= 0); + my ($file, $line) = @caller[1, 2]; warn @_, " at $file line $line.\n"; } sub croak { my $level = 1 + ($Test::Builder::Level || 0); - my ($file, $line) = (caller $level)[1, 2]; + my @caller; + do { + @caller = caller $level--; + } while (!@caller and $level >= 0); + my ($file, $line) = @caller[1, 2]; die @_, " at $file line $line.\n"; } @@ -184,48 +305,10 @@ sub plan { return 1; } -our @EXPORT = qw< - plan - skip - done_testing - pass - fail - ok - is - isnt - like - unlike - cmp_ok - is_deeply - diag - note - BAIL_OUT ->; - sub import { my $class = shift; - my @imports; - my $i = 0; - while ($i <= $#_) { - my $item = $_[$i]; - my $splice; - if (defined $item) { - if ($item eq 'import') { - push @imports, @{ $_[$i+1] }; - $splice = 2; - } elsif ($item eq 'no_diag') { - lock $plan if THREADSAFE; - $no_diag = 1; - $splice = 1; - } - } - if ($splice) { - splice @_, $i, $splice; - } else { - ++$i; - } - } + my @imports = &_handle_import_args; if (@_) { local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1; diff --git a/t/00-load.t b/t/00-load.t index 7721399..988eab1 100644 --- a/t/00-load.t +++ b/t/00-load.t @@ -5,6 +5,8 @@ use warnings; use Test::More tests => 1; +BEGIN { delete $ENV{PERL_TEST_LEANER_USES_TEST_MORE} } + { package Test::Leaner::TestContainer; BEGIN { diff --git a/t/01-import.t b/t/01-import.t index 3b42068..9fe04df 100644 --- a/t/01-import.t +++ b/t/01-import.t @@ -5,7 +5,10 @@ use warnings; use Test::More (); -BEGIN { *tm_is = \&Test::More::is } +BEGIN { + delete $ENV{PERL_TEST_LEANER_USES_TEST_MORE}; + *tm_is = \&Test::More::is; +} Test::More::plan(tests => 2 * 15); diff --git a/t/02-fallback.t b/t/02-fallback.t new file mode 100644 index 0000000..3bda266 --- /dev/null +++ b/t/02-fallback.t @@ -0,0 +1,124 @@ +#!perl -T + +use strict; +use warnings; + +BEGIN { $ENV{PERL_TEST_LEANER_USES_TEST_MORE} = 1 } + +use Test::Leaner; + +BEGIN { + my $loaded; + if ($INC{'Test/More.pm'}) { + $loaded = 1; + } else { + $loaded = 0; + require Test::More; + Test::More->import; + } + Test::More::plan(tests => 1 + 4 * 15 + 3 * 3 + 2 * 8); + Test::More::is($loaded, 1, 'Test::More has been loaded'); +} + +sub get_subroutine { + my ($stash, $name) = @_; + + my $glob = $stash->{$name}; + return undef unless $glob; + + return *$glob{CODE}; +} + +my $leaner_stash = \%Test::Leaner::; +my $more_stash = \%Test::More::; +my $this_stash = \%main::; + +my @exported = qw< + plan + skip + done_testing + pass + fail + ok + is + isnt + like + unlike + cmp_ok + is_deeply + diag + note + BAIL_OUT +>; + +for (@exported) { + my $more_variant = get_subroutine($more_stash, $_); + + my $leaner_variant = get_subroutine($leaner_stash, $_); + Test::More::ok(defined $leaner_variant, + "Test::Leaner variant of $_ is defined"); + my $imported_variant = get_subroutine($this_stash, $_); + Test::More::ok(defined $imported_variant, "imported variant of $_ is defined"); + + SKIP: { + Test::More::skip('Need leaner and imported variants to be defined' => 2) + unless defined $leaner_variant + and defined $imported_variant; + + if (defined $more_variant) { + Test::More::is($leaner_variant, $more_variant, + "Test::Leaner variant of $_ is Test::More variant"); + Test::More::is($imported_variant, $more_variant, + "imported variant of $_ is Test::More variant"); + } else { + Test::More::is($imported_variant, $leaner_variant, + "imported variant of $_ is Test::Leaner variant"); + { + local $@; + eval { $leaner_variant->() }; + Test::More::like($@, qr/^\Q$_\E is not implemented.*at \Q$0\E line \d+/, + "Test::Leaner of $_ variant croaks"); + } + } + } +} + +my @only_in_test_leaner = qw< + tap_stream + diag_stream + THREADSAFE +>; + +for (@only_in_test_leaner) { + Test::More::ok(exists $leaner_stash->{$_}, + "$_ still exists in Test::Leaner"); + Test::More::ok(!exists $more_stash->{$_}, + "$_ was not imported into Test::More"); + Test::More::ok(!exists $this_stash->{$_}, + "$_ was not imported into main"); +} + +my @only_in_test_more = qw< + use_ok + require_ok + can_ok + isa_ok + new_ok + subtest + explain + todo_skip +>; + +for (@only_in_test_more) { + my $more_variant = get_subroutine($more_stash, $_); + + SKIP: { + Test::More::skip("$_ is not implemented in this version of Test::More" => 2) + unless defined $more_variant; + + Test::More::ok(!exists $leaner_stash->{$_}, + "$_ was not imported into Test::Leaner"); + Test::More::ok(!exists $this_stash->{$_}, + "$_ was not imported into main"); + } +} diff --git a/t/05-pass.t b/t/05-pass.t index ecc6df1..8c1cb98 100644 --- a/t/05-pass.t +++ b/t/05-pass.t @@ -5,6 +5,8 @@ use warnings; use Test::More; +BEGIN { delete $ENV{PERL_TEST_LEANER_USES_TEST_MORE} } + use Test::Leaner (); use lib 't/lib'; diff --git a/t/06-fail.t b/t/06-fail.t index 2f1fddf..08d0f13 100644 --- a/t/06-fail.t +++ b/t/06-fail.t @@ -5,6 +5,8 @@ use warnings; use Test::More; +BEGIN { delete $ENV{PERL_TEST_LEANER_USES_TEST_MORE} } + use Test::Leaner (); use lib 't/lib'; diff --git a/t/07-BAIL_OUT.t b/t/07-BAIL_OUT.t index b1fe00b..8fd3964 100644 --- a/t/07-BAIL_OUT.t +++ b/t/07-BAIL_OUT.t @@ -15,6 +15,8 @@ BEGIN { CORE::exit $_[0]; } }; + + delete $ENV{PERL_TEST_LEANER_USES_TEST_MORE}; } use Test::Leaner (); diff --git a/t/10-plan-tests.t b/t/10-plan-tests.t index b4efe8e..2d731ed 100644 --- a/t/10-plan-tests.t +++ b/t/10-plan-tests.t @@ -3,6 +3,8 @@ use strict; use warnings; +BEGIN { delete $ENV{PERL_TEST_LEANER_USES_TEST_MORE} } + use Test::Leaner; plan tests => 2; diff --git a/t/11-plan-no_plan.t b/t/11-plan-no_plan.t index c3722cb..74bbf73 100644 --- a/t/11-plan-no_plan.t +++ b/t/11-plan-no_plan.t @@ -3,6 +3,8 @@ use strict; use warnings; +BEGIN { delete $ENV{PERL_TEST_LEANER_USES_TEST_MORE} } + use Test::Leaner; plan 'no_plan'; diff --git a/t/12-plan-skip_all.t b/t/12-plan-skip_all.t index 6dd36bc..da77919 100644 --- a/t/12-plan-skip_all.t +++ b/t/12-plan-skip_all.t @@ -3,6 +3,8 @@ use strict; use warnings; +BEGIN { delete $ENV{PERL_TEST_LEANER_USES_TEST_MORE} } + use Test::Leaner; plan skip_all => 'testing plan skip_all'; diff --git a/t/13-use-tests.t b/t/13-use-tests.t index c0bc3a7..b739a3f 100644 --- a/t/13-use-tests.t +++ b/t/13-use-tests.t @@ -3,6 +3,8 @@ use strict; use warnings; +BEGIN { delete $ENV{PERL_TEST_LEANER_USES_TEST_MORE} } + use Test::Leaner tests => 2; pass; diff --git a/t/14-use-no_plan.t b/t/14-use-no_plan.t index bbdcf30..575e120 100644 --- a/t/14-use-no_plan.t +++ b/t/14-use-no_plan.t @@ -3,6 +3,8 @@ use strict; use warnings; +BEGIN { delete $ENV{PERL_TEST_LEANER_USES_TEST_MORE} } + use Test::Leaner 'no_plan'; pass; diff --git a/t/15-use-skip_all.t b/t/15-use-skip_all.t index c423d17..60350ca 100644 --- a/t/15-use-skip_all.t +++ b/t/15-use-skip_all.t @@ -3,6 +3,8 @@ use strict; use warnings; +BEGIN { delete $ENV{PERL_TEST_LEANER_USES_TEST_MORE} } + use Test::Leaner skip_all => 'testing use skip_all'; die 'should not be reached'; diff --git a/t/16-done_testing.t b/t/16-done_testing.t index 66f0e34..f078c1f 100644 --- a/t/16-done_testing.t +++ b/t/16-done_testing.t @@ -3,6 +3,8 @@ use strict; use warnings; +BEGIN { delete $ENV{PERL_TEST_LEANER_USES_TEST_MORE} } + use Test::Leaner; plan 'no_plan'; diff --git a/t/17-plan-done_testing.t b/t/17-plan-done_testing.t index 3da4c1f..a3d69f5 100644 --- a/t/17-plan-done_testing.t +++ b/t/17-plan-done_testing.t @@ -3,6 +3,8 @@ use strict; use warnings; +BEGIN { delete $ENV{PERL_TEST_LEANER_USES_TEST_MORE} } + use Test::Leaner; plan tests => 2; diff --git a/t/18-skip.t b/t/18-skip.t index 05fa3ae..722607b 100644 --- a/t/18-skip.t +++ b/t/18-skip.t @@ -3,6 +3,8 @@ use strict; use warnings; +BEGIN { delete $ENV{PERL_TEST_LEANER_USES_TEST_MORE} } + use Test::Leaner tests => 7; pass 'test begin'; diff --git a/t/19-comments.t b/t/19-comments.t index b9ad8cd..9e490ab 100644 --- a/t/19-comments.t +++ b/t/19-comments.t @@ -3,6 +3,8 @@ use strict; use warnings; +BEGIN { delete $ENV{PERL_TEST_LEANER_USES_TEST_MORE} } + use Test::Leaner tests => 1; note <<'NOTE'; diff --git a/t/20-ok.t b/t/20-ok.t index e6fcafe..19e989a 100644 --- a/t/20-ok.t +++ b/t/20-ok.t @@ -3,6 +3,8 @@ use strict; use warnings; +BEGIN { delete $ENV{PERL_TEST_LEANER_USES_TEST_MORE} } + use Test::Leaner tests => 4 + 1 + 2 + 1; ok 1; diff --git a/t/21-ok-failing.t b/t/21-ok-failing.t index c00ab83..c54fde8 100644 --- a/t/21-ok-failing.t +++ b/t/21-ok-failing.t @@ -5,6 +5,8 @@ use warnings; use Test::More; +BEGIN { delete $ENV{PERL_TEST_LEANER_USES_TEST_MORE} } + use Test::Leaner (); use lib 't/lib'; diff --git a/t/22-is.t b/t/22-is.t index 2059fca..d4baf6e 100644 --- a/t/22-is.t +++ b/t/22-is.t @@ -3,6 +3,8 @@ use strict; use warnings; +BEGIN { delete $ENV{PERL_TEST_LEANER_USES_TEST_MORE} } + use Test::Leaner; plan tests => 8; diff --git a/t/24-cmp_ok.t b/t/24-cmp_ok.t index 106ca5f..dee3dc3 100644 --- a/t/24-cmp_ok.t +++ b/t/24-cmp_ok.t @@ -3,6 +3,10 @@ use strict; use warnings; +BEGIN { delete $ENV{PERL_TEST_LEANER_USES_TEST_MORE} } + +use Test::Leaner tests => 7 * 10 + 4 * 7 + 10; + { package Test::Leaner::TestCmpNum; @@ -24,8 +28,6 @@ use warnings; } } -use Test::Leaner tests => 7 * 10 + 4 * 7 + 10; - my @num_tests = ( [ '1.0', '==', '1.0' ], [ '1e0', '==', '1e0' ], diff --git a/t/26-is_deeply.t b/t/26-is_deeply.t index d455040..d4da1dc 100644 --- a/t/26-is_deeply.t +++ b/t/26-is_deeply.t @@ -3,6 +3,8 @@ use strict; use warnings; +BEGIN { delete $ENV{PERL_TEST_LEANER_USES_TEST_MORE} } + use Test::Leaner tests => 21 + 2 + 1 + 2; my $lacunary = [ [ 1, 2, 3 ] => [ 1, 2, 3 ] ]; diff --git a/t/27-is_deeply-failing.t b/t/27-is_deeply-failing.t index e36f9ad..dda1874 100644 --- a/t/27-is_deeply-failing.t +++ b/t/27-is_deeply-failing.t @@ -5,6 +5,8 @@ use warnings; use Test::More; +BEGIN { delete $ENV{PERL_TEST_LEANER_USES_TEST_MORE} } + use Test::Leaner (); use lib 't/lib'; diff --git a/t/28-is_deeply-deep.t b/t/28-is_deeply-deep.t index 2beae50..6c15cd2 100644 --- a/t/28-is_deeply-deep.t +++ b/t/28-is_deeply-deep.t @@ -3,6 +3,8 @@ use strict; use warnings; +BEGIN { delete $ENV{PERL_TEST_LEANER_USES_TEST_MORE} } + use Test::Leaner tests => 2; sub create_chain { diff --git a/t/80-threads.t b/t/80-threads.t index a04d1b9..8d872ee 100644 --- a/t/80-threads.t +++ b/t/80-threads.t @@ -3,6 +3,8 @@ use strict; use warnings; +BEGIN { delete $ENV{PERL_TEST_LEANER_USES_TEST_MORE} } + sub skipall { my ($msg) = @_; require Test::Leaner;