X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FTest%2FBuilder.pm;h=1a2cdb03a342443c3298948676ac1d815215336b;hb=f7c69158501ed4705d71f069f23211f56bd55a2e;hp=ee7f8d3ef503c781e1b6b112bbf176a1bb2bde0d;hpb=0753bcb52ae66039875d495707a7475aa37e80f7;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Test/Builder.pm b/lib/Test/Builder.pm index ee7f8d3..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.70'; -$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'); @@ -360,6 +324,29 @@ 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 @@ -401,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; @@ -448,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; @@ -584,6 +575,7 @@ sub _is_diag { } } + local $Level = $Level + 1; return $self->diag(sprintf <_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;"; @@ -730,6 +723,8 @@ sub _cmp_diag { $got = defined $got ? "'$got'" : 'undef'; $expect = defined $expect ? "'$expect'" : 'undef'; + + local $Level = $Level + 1; return $self->diag(sprintf <diag(sprintf < @@ -1025,8 +1035,8 @@ sub is_fh { my $maybe_fh = shift; return 0 unless defined $maybe_fh; - return 1 if ref $maybe_fh eq 'GLOB'; # its a glob - return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob ref + 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 @@ -1144,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; } @@ -1331,10 +1341,9 @@ sub _new_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; @@ -1349,6 +1358,7 @@ sub _autoflush { } +my($Testout, $Testerr); sub _dup_stdhandles { my $self = shift; @@ -1356,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); @@ -1557,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 @@ -1570,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; } @@ -1586,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 { @@ -1670,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. @@ -1748,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 @@ -1772,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