Upgrade to Test-Simple-0.68. Includes a tweak to

lib/Test/Simple/t/fail-more.t so that all of its tests pass within
the Perl core.

p4raw-id: //depot/perl@30578

8 files changed, 255 insertions, 149 deletions

diff --git a/lib/Test/Builder.pm b/lib/Test/Builder.pm
index d0e992a5ee..b837496f3a 100644
--- a/lib/Test/Builder.pm
+++ b/lib/Test/Builder.pm
@@ -8,7 +8,7 @@ $^C ||= 0;
 
 use strict;
 use vars qw($VERSION);
-$VERSION = '0.36';
+$VERSION = '0.68';
 $VERSION = eval $VERSION;    # make the alpha version come out as a number
 
 # Make Test::Builder thread-safe for ithreads.
@@ -364,8 +364,9 @@ sub skip_all {
 
 =head2 Running tests
 
-These actually run the tests, analogous to the functions in
-Test::More.
+These actually run the tests, analogous to the functions in Test::More.
+
+They all return true if the test passed, false if the test failed.
 
 $name is always optional.
 
@@ -464,26 +465,22 @@ sub _unoverload {
     my $self  = shift;
     my $type  = shift;
 
-    local($@,$!);
-
-    eval { require overload } || return;
+    $self->_try(sub { require overload } ) || return;
 
     foreach my $thing (@_) {
-        eval { 
-            if( _is_object($$thing) ) {
-                if( my $string_meth = overload::Method($$thing, $type) ) {
-                    $$thing = $$thing->$string_meth();
-                }
+        if( $self->_is_object($$thing) ) {
+            if( my $string_meth = overload::Method($$thing, $type) ) {
+                $$thing = $$thing->$string_meth();
             }
-        };
+        }
     }
 }
 
 
 sub _is_object {
-    my $thing = shift;
+    my($self, $thing) = @_;
 
-    return eval { ref $thing && $thing->isa('UNIVERSAL') } ? 1 : 0;
+    return $self->_try(sub { ref $thing && $thing->isa('UNIVERSAL') }) ? 1 : 0;
 }
 
 
@@ -676,97 +673,6 @@ sub unlike {
     $self->_regex_ok($this, $regex, '!~', $name);
 }
 
-=item B<maybe_regex>
-
-  $Test->maybe_regex(qr/$regex/);
-  $Test->maybe_regex('/$regex/');
-
-Convenience method for building testing functions that take regular
-expressions as arguments, but need to work before perl 5.005.
-
-Takes a quoted regular expression produced by qr//, or a string
-representing a regular expression.
-
-Returns a Perl value which may be used instead of the corresponding
-regular expression, or undef if it's argument is not recognised.
-
-For example, a version of like(), sans the useful diagnostic messages,
-could be written as:
-
-  sub laconic_like {
-      my ($self, $this, $regex, $name) = @_;
-      my $usable_regex = $self->maybe_regex($regex);
-      die "expecting regex, found '$regex'\n"
-          unless $usable_regex;
-      $self->ok($this =~ m/$usable_regex/, $name);
-  }
-
-=cut
-
-
-sub maybe_regex {
-    my ($self, $regex) = @_;
-    my $usable_regex = undef;
-
-    return $usable_regex unless defined $regex;
-
-    my($re, $opts);
-
-    # Check for qr/foo/
-    if( ref $regex eq 'Regexp' ) {
-        $usable_regex = $regex;
-    }
-    # Check for '/foo/' or 'm,foo,'
-    elsif( ($re, $opts)        = $regex =~ m{^ /(.*)/ (\w*) $ }sx           or
-           (undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
-         )
-    {
-        $usable_regex = length $opts ? "(?$opts)$re" : $re;
-    }
-
-    return $usable_regex;
-};
-
-sub _regex_ok {
-    my($self, $this, $regex, $cmp, $name) = @_;
-
-    my $ok = 0;
-    my $usable_regex = $self->maybe_regex($regex);
-    unless (defined $usable_regex) {
-        $ok = $self->ok( 0, $name );
-        $self->diag("    '$regex' doesn't look much like a regex to me.");
-        return $ok;
-    }
-
-    {
-        my $test;
-        my $code = $self->_caller_context;
-
-        local($@, $!);
-
-        # Yes, it has to look like this or 5.4.5 won't see the #line directive.
-        # Don't ask me, man, I just work here.
-        $test = eval "
-$code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
-
-        $test = !$test if $cmp eq '!~';
-
-        local $Level = $Level + 1;
-        $ok = $self->ok( $test, $name );
-    }
-
-    unless( $ok ) {
-        $this = defined $this ? "'$this'" : 'undef';
-        my $match = $cmp eq '=~' ? "doesn't match" : "matches";
-        $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
-                  %s
-    %13s '%s'
-DIAGNOSTIC
-
-    }
-
-    return $ok;
-}
 
 =item B<cmp_ok>
 
@@ -795,8 +701,7 @@ sub cmp_ok {
 
     my $test;
     {
-        local($@,$!);   # don't interfere with $@
-                        # eval() sometimes resets $!
+        local($@,$!,$SIG{__DIE__});  # isolate eval
 
         my $code = $self->_caller_context;
 
@@ -844,6 +749,14 @@ sub _caller_context {
     return $code;
 }
 
+=back
+
+
+=head2 Other Testing Methods
+
+These are methods which are used in the course of writing a test but are not themselves tests.
+
+=over 4
 
 =item B<BAIL_OUT>
 
@@ -969,8 +882,164 @@ test.
 =back
 
 
+=head2 Test building utility methods
+
+These methods are useful when writing your own test methods.
+
+=over 4
+
+=item B<maybe_regex>
+
+  $Test->maybe_regex(qr/$regex/);
+  $Test->maybe_regex('/$regex/');
+
+Convenience method for building testing functions that take regular
+expressions as arguments, but need to work before perl 5.005.
+
+Takes a quoted regular expression produced by qr//, or a string
+representing a regular expression.
+
+Returns a Perl value which may be used instead of the corresponding
+regular expression, or undef if it's argument is not recognised.
+
+For example, a version of like(), sans the useful diagnostic messages,
+could be written as:
+
+  sub laconic_like {
+      my ($self, $this, $regex, $name) = @_;
+      my $usable_regex = $self->maybe_regex($regex);
+      die "expecting regex, found '$regex'\n"
+          unless $usable_regex;
+      $self->ok($this =~ m/$usable_regex/, $name);
+  }
+
+=cut
+
+
+sub maybe_regex {
+    my ($self, $regex) = @_;
+    my $usable_regex = undef;
+
+    return $usable_regex unless defined $regex;
+
+    my($re, $opts);
+
+    # Check for qr/foo/
+    if( ref $regex eq 'Regexp' ) {
+        $usable_regex = $regex;
+    }
+    # Check for '/foo/' or 'm,foo,'
+    elsif( ($re, $opts)        = $regex =~ m{^ /(.*)/ (\w*) $ }sx           or
+           (undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
+         )
+    {
+        $usable_regex = length $opts ? "(?$opts)$re" : $re;
+    }
+
+    return $usable_regex;
+};
+
+sub _regex_ok {
+    my($self, $this, $regex, $cmp, $name) = @_;
+
+    my $ok = 0;
+    my $usable_regex = $self->maybe_regex($regex);
+    unless (defined $usable_regex) {
+        $ok = $self->ok( 0, $name );
+        $self->diag("    '$regex' doesn't look much like a regex to me.");
+        return $ok;
+    }
+
+    {
+        my $test;
+        my $code = $self->_caller_context;
+
+        local($@, $!, $SIG{__DIE__}); # isolate eval
+
+        # Yes, it has to look like this or 5.4.5 won't see the #line directive.
+        # Don't ask me, man, I just work here.
+        $test = eval "
+$code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
+
+        $test = !$test if $cmp eq '!~';
+
+        local $Level = $Level + 1;
+        $ok = $self->ok( $test, $name );
+    }
+
+    unless( $ok ) {
+        $this = defined $this ? "'$this'" : 'undef';
+        my $match = $cmp eq '=~' ? "doesn't match" : "matches";
+        $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
+                  %s
+    %13s '%s'
+DIAGNOSTIC
+
+    }
+
+    return $ok;
+}
+
+
+# I'm not ready to publish this.  It doesn't deal with array return
+# values from the code or context.
+=begin private
+
+=item B<_try>
+
+    my $return_from_code          = $Test->try(sub { code });
+    my($return_from_code, $error) = $Test->try(sub { code });
+
+Works like eval BLOCK except it ensures it has no effect on the rest of the test (ie. $@ is not set) nor is effected by outside interference (ie. $SIG{__DIE__}) and works around some quirks in older Perls.
+
+$error is what would normally be in $@.
+
+It is suggested you use this in place of eval BLOCK.
+
+=cut
+
+sub _try {
+    my($self, $code) = @_;
+    
+    local $!;               # eval can mess up $!
+    local $@;               # don't set $@ in the test
+    local $SIG{__DIE__};    # don't trip an outside DIE handler.
+    my $return = eval { $code->() };
+    
+    return wantarray ? ($return, $@) : $return;
+}
+
+=end private
+
+
+=item B<is_fh>
+
+    my $is_fh = $Test->is_fh($thing);
+
+Determines if the given $thing can be used as a filehandle.
+
+=cut
+
+sub is_fh {
+    my $self = shift;
+    my $maybe_fh = shift;
+    return 0 unless defined $maybe_fh;
+
+    return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
+
+    return eval { $maybe_fh->isa("GLOB") }       ||
+           eval { $maybe_fh->isa("IO::Handle") } ||
+           # 5.5.4's tied() and can() doesn't like getting undef
+           eval { (tied($maybe_fh) || '')->can('TIEHANDLE') };
+}
+
+
+=back
+
+
 =head2 Test style
 
+
 =over 4
 
 =item B<level>
@@ -982,14 +1051,18 @@ test failed.
 
 Defaults to 1.
 
-Setting $Test::Builder::Level overrides.  This is typically useful
+Setting L<$Test::Builder::Level> overrides.  This is typically useful
 localized:
 
-    {
-        local $Test::Builder::Level = 2;
-        $Test->ok($test);
+    sub my_ok {
+        my $test = shift;
+
+        local $Test::Builder::Level = $Test::Builder::Level + 1;
+        $TB->ok($test);
     }
 
+To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant.
+
 =cut
 
 sub level {
@@ -1254,7 +1327,7 @@ sub _new_fh {
     my($file_or_fh) = shift;
 
     my $fh;
-    if( $self->_is_fh($file_or_fh) ) {
+    if( $self->is_fh($file_or_fh) ) {
         $fh = $file_or_fh;
     }
     else {
@@ -1268,21 +1341,6 @@ sub _new_fh {
 }
 
 
-sub _is_fh {
-    my $self = shift;
-    my $maybe_fh = shift;
-    return 0 unless defined $maybe_fh;
-
-    return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
-
-    return UNIVERSAL::isa($maybe_fh,               'GLOB')       ||
-           UNIVERSAL::isa($maybe_fh,               'IO::Handle') ||
-
-           # 5.5.4's tied() and can() doesn't like getting undef
-           UNIVERSAL::can((tied($maybe_fh) || ''), 'TIEHANDLE');
-}
-
-
 sub _autoflush {
     my($fh) = shift;
     my $old_fh = select $fh;
diff --git a/lib/Test/Builder/Module.pm b/lib/Test/Builder/Module.pm
index d680739e67..06604ea4b2 100644
--- a/lib/Test/Builder/Module.pm
+++ b/lib/Test/Builder/Module.pm
@@ -5,7 +5,7 @@ use Test::Builder;
 require Exporter;
 @ISA = qw(Exporter);
 
-$VERSION = '0.06';
+$VERSION = '0.68';
 
 use strict;
 
diff --git a/lib/Test/More.pm b/lib/Test/More.pm
index 4b7422c14f..7a2c2aa7c4 100644
--- a/lib/Test/More.pm
+++ b/lib/Test/More.pm
@@ -16,7 +16,7 @@ sub _carp {
 
 
 use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
-$VERSION = '0.67';
+$VERSION = '0.68';
 $VERSION = eval $VERSION;    # make the alpha version come out as a number
 
 use Test::Builder::Module;
@@ -479,9 +479,7 @@ sub can_ok ($@) {
 
     my @nok = ();
     foreach my $method (@methods) {
-        local($!, $@);  # don't interfere with caller's $@
-                        # eval sometimes resets $!
-        eval { $proto->can($method) } || push @nok, $method;
+        $tb->_try(sub { $proto->can($method) }) or push @nok, $method;
     }
 
     my $name;
@@ -539,10 +537,10 @@ sub isa_ok ($$;$) {
     }
     else {
         # We can't use UNIVERSAL::isa because we want to honor isa() overrides
-        local($@, $!);  # eval sometimes resets $!
-        my $rslt = eval { $object->isa($class) };
-        if( $@ ) {
-            if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) {
+        my($rslt, $error) = $tb->_try(sub { $object->isa($class) });
+        if( $error ) {
+            if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
+                # Its an unblessed reference
                 if( !UNIVERSAL::isa($object, $class) ) {
                     my $ref = ref $object;
                     $diag = "$obj_name isn't a '$class' it's a '$ref'";
@@ -550,9 +548,8 @@ sub isa_ok ($$;$) {
             } else {
                 die <<WHOA;
 WHOA! I tried to call ->isa on your object and got some weird error.
-This should never happen.  Please contact the author immediately.
 Here's the error.
-$@
+$error
 WHOA
             }
         }
@@ -662,7 +659,7 @@ sub use_ok ($;@) {
 
     my($pack,$filename,$line) = caller;
 
-    local($@,$!);   # eval sometimes interferes with $!
+    local($@,$!,$SIG{__DIE__});   # isolate eval
 
     if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
         # probably a version check.  Perl needs to see the bare number
@@ -714,7 +711,8 @@ sub require_ok ($) {
     # Module names must be barewords, files not.
     $module = qq['$module'] unless _is_module_name($module);
 
-    local($!, $@); # eval sometimes interferes with $!
+    local($!, $@, $SIG{__DIE__}); # isolate eval
+    local $SIG{__DIE__};
     eval <<REQUIRE;
 package $pack;
 require $module;
diff --git a/lib/Test/Simple.pm b/lib/Test/Simple.pm
index 3e16b0c6af..16922e6952 100644
--- a/lib/Test/Simple.pm
+++ b/lib/Test/Simple.pm
@@ -4,7 +4,7 @@ use 5.004;
 
 use strict 'vars';
 use vars qw($VERSION @ISA @EXPORT);
-$VERSION = '0.67';
+$VERSION = '0.68';
 $VERSION = eval $VERSION;    # make the alpha version come out as a number
 
 use Test::Builder::Module;
diff --git a/lib/Test/Simple/Changes b/lib/Test/Simple/Changes
index e2f50bc22f..c7c0c55143 100644
--- a/lib/Test/Simple/Changes
+++ b/lib/Test/Simple/Changes
@@ -1,3 +1,38 @@
+0.68  Tue Mar 13 17:27:26 PDT 2007
+    Bug fixes
+    * If your code has a $SIG{__DIE__} handler in some cases functions like
+      use_ok(), require_ok(), can_ok() and isa_ok() could trigger that
+      handler. [rt.cpan.org 23509]
+    - Minor improvement to TB's filehandle detection in the case of overridden
+      isa(). [rt.cpan.org 20890]
+    - Will now install as a core module in 5.6.2 which ships with Test::More.
+      [rt.cpan.org 25163]
+
+    New Features
+    - Test::Builder->is_fh() provides a way to determine if a thing
+      can be used as a filehandle.
+
+    Documentation improvements
+    - Improved the docs for $Test::Builder::Level showing the encouraged
+      use (increment, don't set)
+    - Documented the return value of Test::Builder's test methods
+    - Split out TB's method documentation to differenciate between test
+      methods (ok, is_eq...), methods useful in testing (skip, BAILOUT...)
+      and methods useful for building your own tests (maybe_regex...).
+
+    Test fixes
+    - We required too old a version of Test::Pod::Coverage.  Need 1.08 and not
+      1.00. [rt.cpan.org 25351]
+
+0.67  Mon Jan 22 13:27:40 PST 2007
+    Test fixes
+    - t/pod_coverage.t would fail if Test::Pod::Coverage between 1.07 and
+      1.00 were installed as it depended on all_modules being exported.
+      [rt.cpan.org 24483]
+
+0.66  Sun Dec  3 15:25:45 PST 2006
+    - Restore 5.4.5 compatibility (unobe@cpan.org) [rt.cpan.org 20513]
+
 0.65  Fri Nov 10 10:26:51 CST 2006
 
 0.64_03  Sun Nov  5 13:09:55 EST 2006
diff --git a/lib/Test/Simple/t/fail-more.t b/lib/Test/Simple/t/fail-more.t
index 20e3261611..b401fd67f2 100644
--- a/lib/Test/Simple/t/fail-more.t
+++ b/lib/Test/Simple/t/fail-more.t
@@ -45,9 +45,13 @@ sub main::err_ok ($) {
 package main;
 
 require Test::More;
-my $Total = 29;
+my $Total = 30;
 Test::More->import(tests => $Total);
 
+# This should all work in the presence of a __DIE__ handler.
+local $SIG{__DIE__} = sub { $TB->ok(0, "DIE handler called: ".join "", @_); };
+
+
 my $tb = Test::More->builder;
 $tb->use_numbers(0);
 
@@ -142,6 +146,7 @@ ERR
 can_ok('Mooble::Hooble::Yooble', qw(this that));
 can_ok('Mooble::Hooble::Yooble', ());
 can_ok(undef, undef);
+can_ok([], "foo");
 err_ok( <<ERR );
 #   Failed test 'Mooble::Hooble::Yooble->can(...)'
 #   at $0 line 52.
@@ -153,6 +158,9 @@ err_ok( <<ERR );
 #   Failed test '->can(...)'
 #   at $0 line 54.
 #     can_ok() called with empty class or reference
+#   Failed test 'ARRAY->can('foo')'
+#   at t/fail-more.t line 55.
+#     ARRAY->can('foo') failed
 ERR
 
 #line 55
@@ -293,6 +301,7 @@ not ok - fail()
 not ok - Mooble::Hooble::Yooble->can(...)
 not ok - Mooble::Hooble::Yooble->can(...)
 not ok - ->can(...)
+not ok - ARRAY->can('foo')
 not ok - The object isa Wibble
 not ok - My Wibble isa Wibble
 not ok - Another Wibble isa Wibble
diff --git a/lib/Test/Simple/t/is_fh.t b/lib/Test/Simple/t/is_fh.t
index 2661f6869f..e12af92c0b 100644
--- a/lib/Test/Simple/t/is_fh.t
+++ b/lib/Test/Simple/t/is_fh.t
@@ -14,16 +14,16 @@ use strict;
 use Test::More tests => 8;
 use TieOut;
 
-ok( !Test::Builder->_is_fh("foo"), 'string is not a filehandle' );
-ok( !Test::Builder->_is_fh(''),    'empty string' );
-ok( !Test::Builder->_is_fh(undef), 'undef' );
+ok( !Test::Builder->is_fh("foo"), 'string is not a filehandle' );
+ok( !Test::Builder->is_fh(''),    'empty string' );
+ok( !Test::Builder->is_fh(undef), 'undef' );
 
 ok( open(FILE, '>foo') );
 END { close FILE; unlink 'foo' }
 
-ok( Test::Builder->_is_fh(*FILE) );
-ok( Test::Builder->_is_fh(\*FILE) );
-ok( Test::Builder->_is_fh(*FILE{IO}) );
+ok( Test::Builder->is_fh(*FILE) );
+ok( Test::Builder->is_fh(\*FILE) );
+ok( Test::Builder->is_fh(*FILE{IO}) );
 
 tie *OUT, 'TieOut';
-ok( Test::Builder->_is_fh(*OUT) );
+ok( Test::Builder->is_fh(*OUT) );
diff --git a/lib/Test/Simple/t/overload.t b/lib/Test/Simple/t/overload.t
index e0e70d4229..d5e4c102ea 100644
--- a/lib/Test/Simple/t/overload.t
+++ b/lib/Test/Simple/t/overload.t
@@ -37,6 +37,12 @@ sub new {
 
 package main;
 
+local $SIG{__DIE__} = sub {
+    my($call_file, $call_line) = (caller)[1,2];
+    fail("SIGDIE accidentally called");
+    diag("From $call_file at $call_line");
+};
+
 my $obj = Overloaded->new('foo', 42);
 isa_ok $obj, 'Overloaded';