X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FTest%2FBuilder.pm;h=1a2cdb03a342443c3298948676ac1d815215336b;hb=f7c69158501ed4705d71f069f23211f56bd55a2e;hp=d0b379aba41df6128e30f7365af53ea6c3ca6019;hpb=b7f9bbeb27deb5ace5bde1b13a5221532eb90ed0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Test/Builder.pm b/lib/Test/Builder.pm index d0b379a..1a2cdb0 100644 --- a/lib/Test/Builder.pm +++ b/lib/Test/Builder.pm @@ -1,15 +1,10 @@ package Test::Builder; -use 5.004; - -# $^C was only introduced in 5.005-ish. We do this to prevent -# use of uninitialized value warnings in older perls. -$^C ||= 0; - +use 5.006; use strict; -use vars qw($VERSION); -$VERSION = '0.33_02'; -$VERSION = eval $VERSION; # make the alpha version come out as a number + +our $VERSION = '0.80'; +$VERSION = eval { $VERSION }; # make the alpha version come out as a number # Make Test::Builder thread-safe for ithreads. BEGIN { @@ -73,28 +68,15 @@ Test::Builder - Backend for building test libraries =head1 SYNOPSIS package My::Test::Module; - use Test::Builder; - require Exporter; - @ISA = qw(Exporter); - @EXPORT = qw(ok); - - my $Test = Test::Builder->new; - $Test->output('my_logfile'); - - sub import { - my($self) = shift; - my $pack = caller; + use base 'Test::Builder::Module'; - $Test->exported_to($pack); - $Test->plan(@_); - - $self->export_to_level(1, $self, 'ok'); - } + my $CLASS = __PACKAGE__; sub ok { my($test, $name) = @_; + my $tb = $CLASS->builder; - $Test->ok($test, $name); + $tb->ok($test, $name); } @@ -177,7 +159,6 @@ sub reset { # hash keys is just asking for pain. Also, it was documented. $Level = 1; - $self->{Test_Died} = 0; $self->{Have_Plan} = 0; $self->{No_Plan} = 0; $self->{Original_Pid} = $$; @@ -196,9 +177,11 @@ sub reset { $self->{No_Header} = 0; $self->{No_Ending} = 0; + $self->{TODO} = undef; + $self->_dup_stdhandles unless $^C; - return undef; + return; } =back @@ -210,25 +193,6 @@ are. You usually only want to call one of these methods. =over 4 -=item B - - my $pack = $Test->exported_to; - $Test->exported_to($pack); - -Tells Test::Builder what package you exported your functions to. -This is important for getting TODO tests right. - -=cut - -sub exported_to { - my($self, $pack) = @_; - - if( defined $pack ) { - $self->{Exported_To} = $pack; - } - return $self->{Exported_To}; -} - =item B $Test->plan('no_plan'); @@ -247,6 +211,8 @@ sub plan { return unless $cmd; + local $Level = $Level + 1; + if( $self->{Have_Plan} ) { $self->croak("You tried to plan twice"); } @@ -358,12 +324,36 @@ sub skip_all { exit(0); } + +=item B + + my $pack = $Test->exported_to; + $Test->exported_to($pack); + +Tells Test::Builder what package you exported your functions to. + +This method isn't terribly useful since modules which share the same +Test::Builder object might get exported to different packages and only +the last one will be honored. + +=cut + +sub exported_to { + my($self, $pack) = @_; + + if( defined $pack ) { + $self->{Exported_To} = $pack; + } + return $self->{Exported_To}; +} + =back =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. @@ -398,9 +388,12 @@ sub ok { Very confusing. ERR - my($pack, $file, $line) = $self->caller; + my $todo = $self->todo(); + + # Capture the value of $TODO for the rest of this ok() call + # so it can more easily be found by other routines. + local $self->{TODO} = $todo; - my $todo = $self->todo($pack); $self->_unoverload_str(\$todo); my $out; @@ -445,13 +438,14 @@ ERR my $msg = $todo ? "Failed (TODO)" : "Failed"; $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE}; - if( defined $name ) { - $self->diag(qq[ $msg test '$name'\n]); - $self->diag(qq[ at $file line $line.\n]); - } - else { - $self->diag(qq[ $msg test at $file line $line.\n]); - } + my(undef, $file, $line) = $self->caller; + if( defined $name ) { + $self->diag(qq[ $msg test '$name'\n]); + $self->diag(qq[ at $file line $line.\n]); + } + else { + $self->diag(qq[ $msg test at $file line $line.\n]); + } } return $test ? 1 : 0; @@ -462,26 +456,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; } @@ -585,6 +575,7 @@ sub _is_diag { } } + local $Level = $Level + 1; return $self->diag(sprintf <_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 < @@ -793,12 +693,12 @@ sub cmp_ok { my $test; { - local($@,$!); # don't interfere with $@ - # eval() sometimes resets $! + local($@,$!,$SIG{__DIE__}); # isolate eval my $code = $self->_caller_context; - # Yes, it has to look like this or 5.4.5 won't see the #line directive. + # 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" . "\$got $type \$expect;"; @@ -823,6 +723,8 @@ sub _cmp_diag { $got = defined $got ? "'$got'" : 'undef'; $expect = defined $expect ? "'$expect'" : 'undef'; + + local $Level = $Level + 1; return $self->diag(sprintf < @@ -967,8 +877,179 @@ 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( _is_qr($regex) ) { + $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 _is_qr { + my $regex = shift; + + # is_regexp() checks for regexes in a robust manner, say if they're + # blessed. + return re::is_regexp($regex) if defined &re::is_regexp; + return ref $regex eq 'Regexp'; +} + + +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"; + + local $Level = $Level + 1; + $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 ref + return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob + + return 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 @@ -980,14 +1061,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 { @@ -1019,8 +1104,6 @@ or this if false Most useful when you can't depend on the test output order, such as when threads or forking is involved. -Test::Harness will accept either, but avoid mixing the two styles. - Defaults to on. =cut @@ -1071,7 +1154,7 @@ foreach my $attribute (qw(No_Header No_Ending No_Diag)) { return $self->{$attribute}; }; - no strict 'refs'; + no strict 'refs'; ## no critic *{__PACKAGE__.'::'.$method} = $code; } @@ -1254,35 +1337,19 @@ 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 { - $fh = do { local *FH }; - open $fh, ">$file_or_fh" or + open $fh, ">", $file_or_fh or $self->croak("Can't open test output log $file_or_fh: $!"); - _autoflush($fh); + _autoflush($fh); } return $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; @@ -1291,6 +1358,7 @@ sub _autoflush { } +my($Testout, $Testerr); sub _dup_stdhandles { my $self = shift; @@ -1298,28 +1366,46 @@ sub _dup_stdhandles { # Set everything to unbuffered else plain prints to STDOUT will # come out in the wrong order from our own prints. - _autoflush(\*TESTOUT); + _autoflush($Testout); _autoflush(\*STDOUT); - _autoflush(\*TESTERR); + _autoflush($Testerr); _autoflush(\*STDERR); - $self->output(\*TESTOUT); - $self->failure_output(\*TESTERR); - $self->todo_output(\*TESTOUT); + $self->output ($Testout); + $self->failure_output($Testerr); + $self->todo_output ($Testout); } my $Opened_Testhandles = 0; sub _open_testhandles { + my $self = shift; + return if $Opened_Testhandles; + # We dup STDOUT and STDERR so people can change them in their # test suites while still getting normal test output. - open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!"; - open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!"; + open( $Testout, ">&STDOUT") or die "Can't dup STDOUT: $!"; + open( $Testerr, ">&STDERR") or die "Can't dup STDERR: $!"; + +# $self->_copy_io_layers( \*STDOUT, $Testout ); +# $self->_copy_io_layers( \*STDERR, $Testerr ); + $Opened_Testhandles = 1; } +sub _copy_io_layers { + my($self, $src, $dst) = @_; + + $self->_try(sub { + require PerlIO; + my @src_layers = PerlIO::get_layers($src); + + binmode $dst, join " ", map ":$_", @src_layers if @src_layers; + }); +} + =item carp $tb->carp(@message); @@ -1339,7 +1425,7 @@ point where the original test function was called (C<$tb->caller>). sub _message_at_caller { my $self = shift; - local $Level = $Level + 2; + local $Level = $Level + 1; my($pack, $file, $line) = $self->caller; return join("", @_) . " at $file line $line.\n"; } @@ -1358,7 +1444,7 @@ sub _plan_check { my $self = shift; unless( $self->{Have_Plan} ) { - local $Level = $Level + 1; + local $Level = $Level + 2; $self->croak("You tried to run a test without a plan"); } } @@ -1499,9 +1585,10 @@ will be considered 'todo' (see Test::More and Test::Harness for details). Returns the reason (ie. the value of $TODO) if running as todo tests, false otherwise. -todo() is about finding the right package to look for $TODO in. It -uses the exported_to() package to find it. If that's not set, it's -pretty good at guessing the right package to look at based on $Level. +todo() is about finding the right package to look for $TODO in. It's +pretty good at guessing the right package to look at. It first looks for +the caller based on C<$Level + 1>, since C is usually called inside +a test function. As a last resort it will use C. Sometimes there is some confusion about where todo() should be looking for the $TODO variable. If you want to be sure, tell it explicitly @@ -1512,10 +1599,12 @@ what $pack to use. sub todo { my($self, $pack) = @_; - $pack = $pack || $self->exported_to || $self->caller($Level); + return $self->{TODO} if defined $self->{TODO}; + + $pack = $pack || $self->caller(1) || $self->exported_to; return 0 unless $pack; - no strict 'refs'; + no strict 'refs'; ## no critic return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'} : 0; } @@ -1528,6 +1617,8 @@ sub todo { Like the normal caller(), except it reports according to your level(). +C<$height> will be added to the level(). + =cut sub caller { @@ -1612,35 +1703,27 @@ sub _my_exit { =cut -$SIG{__DIE__} = sub { - # We don't want to muck with death in an eval, but $^S isn't - # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing - # with it. Instead, we use caller. This also means it runs under - # 5.004! - my $in_eval = 0; - for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) { - $in_eval = 1 if $sub =~ /^\(eval\)/; - } - $Test->{Test_Died} = 1 unless $in_eval; -}; - sub _ending { my $self = shift; + my $real_exit_code = $?; $self->_sanity_check(); # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. + if( $self->{Original_Pid} != $$ ) { + return; + } + # Exit if plan() was never called. This is so "require Test::Simple" # doesn't puke. + if( !$self->{Have_Plan} ) { + return; + } + # Don't do an ending if we bailed out. - if( ($self->{Original_Pid} != $$) or - (!$self->{Have_Plan} && !$self->{Test_Died}) or - $self->{Bailed_Out} - ) - { - _my_exit($?); - return; + if( $self->{Bailed_Out} ) { + return; } # Figure out if we passed or failed and print helpful messages. @@ -1690,7 +1773,7 @@ Looks like you failed $num_failed test$s of $num_tests$qualifier. FAIL } - if( $self->{Test_Died} ) { + if( $real_exit_code ) { $self->diag(<<"FAIL"); Looks like your test died just after $self->{Curr_Test}. FAIL @@ -1714,7 +1797,7 @@ FAIL elsif ( $self->{Skip_All} ) { _my_exit( 0 ) && return; } - elsif ( $self->{Test_Died} ) { + elsif ( $real_exit_code ) { $self->diag(<<'FAIL'); Looks like your test died before it could output anything. FAIL