From c00d8759700007aca60d0253234eb4ad2ad948a6 Mon Sep 17 00:00:00 2001 From: Steve Peters Date: Wed, 14 Mar 2007 13:17:42 +0000 Subject: [PATCH] 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 --- lib/Test/Builder.pm | 312 +++++++++++++++++++++++++----------------- lib/Test/Builder/Module.pm | 2 +- lib/Test/More.pm | 22 ++- lib/Test/Simple.pm | 2 +- lib/Test/Simple/Changes | 35 +++++ lib/Test/Simple/t/fail-more.t | 11 +- lib/Test/Simple/t/is_fh.t | 14 +- lib/Test/Simple/t/overload.t | 6 + 8 files changed, 255 insertions(+), 149 deletions(-) diff --git a/lib/Test/Builder.pm b/lib/Test/Builder.pm index d0e992a..b837496 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 - - $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 < @@ -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 @@ -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 + + $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 < + + 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 + + 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 @@ -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 d680739..06604ea 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 4b7422c..7a2c2aa 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 <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 <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 20e3261..b401fd6 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( <can(...)' # at $0 line 52. @@ -153,6 +158,9 @@ err_ok( <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 2661f68..e12af92 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 e0e70d4..d5e4c10 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'; -- 1.8.3.1