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.
=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.
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;
}
$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>
my $test;
{
- local($@,$!); # don't interfere with $@
- # eval() sometimes resets $!
+ local($@,$!,$SIG{__DIE__}); # isolate eval
my $code = $self->_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>
=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>
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 {
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 {
}
-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;
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;
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;
}
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'";
} 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
}
}
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
# 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;
projects / p5sagit/p5-mst-13.2.git / commitdiff