From: Vincent Pit <vince@profvince.com>
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/?p=perl%2Fmodules%2FTest-Leaner.git;a=commitdiff_plain;h=653bd706f7c17c61e34d98e6fcaed75861b2f7d7

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<PERL_TEST_LEANER_USES_TEST_MORE>
+
+If this environment variable is set, L<Test::Leaner> will replace its functions by those from L<Test::More>.
+Moreover, the symbols that are imported you C<use Test::Leaner> will be those from L<Test::More>, but you can still only import the symbols originally defined in L<Test::Leaner> (hence the functions from L<Test::More> that are not implemented in L<Test::Leaner> will not be imported).
+If your version of L<Test::More> is too old and doesn't have some symbols (like L</note> or L</done_testing>), they will be replaced in L<Test::Leaner> by croaking stubs.
+
+This may be useful if your L<Test::Leaner>-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;