X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FTest%2FBuilder.pm;h=859915b69e01d3b276c5a95caeb4b6ccbc673805;hb=5143c659fadb184e0a7d17e727769f92c91d37b7;hp=9f6a3a43ddc13d54d872ffa47355a2c6fef42354;hpb=b4ec42b69d9617082490f2c4d5d6882716a48762;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Test/Builder.pm b/lib/Test/Builder.pm index 9f6a3a4..859915b 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.22'; +$VERSION = '0.30'; $VERSION = eval $VERSION; # make the alpha version come out as a number # Make Test::Builder thread-safe for ithreads. @@ -115,19 +115,48 @@ work together>. Returns a Test::Builder object representing the current state of the test. -Since you only run one test per program, there is B +Since you only run one test per program C always returns the same Test::Builder object. No matter how many times you call new(), you're -getting the same object. (This is called a singleton). +getting the same object. This is called a singleton. This is done so that +multiple modules share such global information as the test counter and +where test output is going. + +If you want a completely new Test::Builder object different from the +singleton, use C. =cut my $Test = Test::Builder->new; sub new { my($class) = shift; - $Test ||= bless ['Move along, nothing to see here'], $class; + $Test ||= $class->create; return $Test; } + +=item B + + my $Test = Test::Builder->create; + +Ok, so there can be more than one Test::Builder object and this is how +you get it. You might use this instead of C if you're testing +a Test::Builder based module, but otherwise you probably want C. + +B: the implementation is not complete. C, for example, is +still shared amongst B Test::Builder objects, even ones created using +this method. Also, the method name may change in the future. + +=cut + +sub create { + my $class = shift; + + my $self = bless {}, $class; + $self->reset; + + return $self; +} + =item B $Test->reset; @@ -138,44 +167,33 @@ test might be run multiple times in the same process. =cut -my $Test_Died; -my $Have_Plan; -my $No_Plan; -my $Curr_Test; share($Curr_Test); use vars qw($Level); -my $Original_Pid; -my @Test_Results; share(@Test_Results); - -my $Exported_To; -my $Expected_Tests; - -my $Skip_All; - -my $Use_Nums; - -my($No_Header, $No_Ending); - -$Test->reset; sub reset { my ($self) = @_; - $Test_Died = 0; - $Have_Plan = 0; - $No_Plan = 0; - $Curr_Test = 0; - $Level = 1; - $Original_Pid = $$; - @Test_Results = (); + # We leave this a global because it has to be localized and localizing + # 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} = $$; - $Exported_To = undef; - $Expected_Tests = 0; + share($self->{Curr_Test}); + $self->{Curr_Test} = 0; + $self->{Test_Results} = &share([]); - $Skip_All = 0; + $self->{Exported_To} = undef; + $self->{Expected_Tests} = 0; - $Use_Nums = 1; + $self->{Skip_All} = 0; - ($No_Header, $No_Ending) = (0,0); + $self->{Use_Nums} = 1; + + $self->{No_Header} = 0; + $self->{No_Ending} = 0; $self->_dup_stdhandles unless $^C; @@ -205,9 +223,9 @@ sub exported_to { my($self, $pack) = @_; if( defined $pack ) { - $Exported_To = $pack; + $self->{Exported_To} = $pack; } - return $Exported_To; + return $self->{Exported_To}; } =item B @@ -228,7 +246,7 @@ sub plan { return unless $cmd; - if( $Have_Plan ) { + if( $self->{Have_Plan} ) { die sprintf "You tried to plan twice! Second plan at %s line %d\n", ($self->caller)[1,2]; } @@ -278,12 +296,12 @@ sub expected_tests { die "Number of tests must be a postive integer. You gave it '$max'.\n" unless $max =~ /^\+?\d+$/ and $max > 0; - $Expected_Tests = $max; - $Have_Plan = 1; + $self->{Expected_Tests} = $max; + $self->{Have_Plan} = 1; $self->_print("1..$max\n") unless $self->no_header; } - return $Expected_Tests; + return $self->{Expected_Tests}; } @@ -296,22 +314,26 @@ Declares that this test will run an indeterminate # of tests. =cut sub no_plan { - $No_Plan = 1; - $Have_Plan = 1; + my $self = shift; + + $self->{No_Plan} = 1; + $self->{Have_Plan} = 1; } =item B $plan = $Test->has_plan - + Find out whether a plan has been defined. $plan is either C (no plan has been set), C (indeterminate # of tests) or an integer (the number of expected tests). =cut sub has_plan { - return($Expected_Tests) if $Expected_Tests; - return('no_plan') if $No_Plan; - return(undef); + my $self = shift; + + return($self->{Expected_Tests}) if $self->{Expected_Tests}; + return('no_plan') if $self->{No_Plan}; + return(undef); }; @@ -331,7 +353,7 @@ sub skip_all { $out .= " # Skip $reason" if $reason; $out .= "\n"; - $Skip_All = 1; + $self->{Skip_All} = 1; $self->_print($out) unless $self->no_header; exit(0); @@ -364,13 +386,13 @@ sub ok { # store, so we turn it into a boolean. $test = $test ? 1 : 0; - unless( $Have_Plan ) { + unless( $self->{Have_Plan} ) { require Carp; Carp::croak("You tried to run a test without a plan! Gotta have a plan."); } - lock $Curr_Test; - $Curr_Test++; + lock $self->{Curr_Test}; + $self->{Curr_Test}++; # In case $name is a string overloaded object, force it to stringify. $self->_unoverload(\$name); @@ -397,7 +419,7 @@ ERR } $out .= "ok"; - $out .= " $Curr_Test" if $self->use_numbers; + $out .= " $self->{Curr_Test}" if $self->use_numbers; if( defined $name ) { $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. @@ -418,7 +440,7 @@ ERR $result->{type} = ''; } - $Test_Results[$Curr_Test-1] = $result; + $self->{Test_Results}[$self->{Curr_Test}-1] = $result; $out .= "\n"; $self->_print($out); @@ -771,15 +793,15 @@ sub skip { $why ||= ''; $self->_unoverload(\$why); - unless( $Have_Plan ) { + unless( $self->{Have_Plan} ) { require Carp; Carp::croak("You tried to run tests without a plan! Gotta have a plan."); } - lock($Curr_Test); - $Curr_Test++; + lock($self->{Curr_Test}); + $self->{Curr_Test}++; - $Test_Results[$Curr_Test-1] = &share({ + $self->{Test_Results}[$self->{Curr_Test}-1] = &share({ 'ok' => 1, actual_ok => 1, name => '', @@ -788,12 +810,12 @@ sub skip { }); my $out = "ok"; - $out .= " $Curr_Test" if $self->use_numbers; + $out .= " $self->{Curr_Test}" if $self->use_numbers; $out .= " # skip"; $out .= " $why" if length $why; $out .= "\n"; - $Test->_print($out); + $self->_print($out); return 1; } @@ -815,15 +837,15 @@ sub todo_skip { my($self, $why) = @_; $why ||= ''; - unless( $Have_Plan ) { + unless( $self->{Have_Plan} ) { require Carp; Carp::croak("You tried to run tests without a plan! Gotta have a plan."); } - lock($Curr_Test); - $Curr_Test++; + lock($self->{Curr_Test}); + $self->{Curr_Test}++; - $Test_Results[$Curr_Test-1] = &share({ + $self->{Test_Results}[$self->{Curr_Test}-1] = &share({ 'ok' => 1, actual_ok => 0, name => '', @@ -832,10 +854,10 @@ sub todo_skip { }); my $out = "not ok"; - $out .= " $Curr_Test" if $self->use_numbers; + $out .= " $self->{Curr_Test}" if $self->use_numbers; $out .= " # TODO & SKIP $why\n"; - $Test->_print($out); + $self->_print($out); return 1; } @@ -921,9 +943,9 @@ sub use_numbers { my($self, $use_nums) = @_; if( defined $use_nums ) { - $Use_Nums = $use_nums; + $self->{Use_Nums} = $use_nums; } - return $Use_Nums; + return $self->{Use_Nums}; } =item B @@ -947,18 +969,18 @@ sub no_header { my($self, $no_header) = @_; if( defined $no_header ) { - $No_Header = $no_header; + $self->{No_Header} = $no_header; } - return $No_Header; + return $self->{No_Header}; } sub no_ending { my($self, $no_ending) = @_; if( defined $no_ending ) { - $No_Ending = $no_ending; + $self->{No_Ending} = $no_ending; } - return $No_Ending; + return $self->{No_Ending}; } @@ -1102,32 +1124,31 @@ Defaults to STDOUT. =cut -my($Out_FH, $Fail_FH, $Todo_FH); sub output { my($self, $fh) = @_; if( defined $fh ) { - $Out_FH = _new_fh($fh); + $self->{Out_FH} = _new_fh($fh); } - return $Out_FH; + return $self->{Out_FH}; } sub failure_output { my($self, $fh) = @_; if( defined $fh ) { - $Fail_FH = _new_fh($fh); + $self->{Fail_FH} = _new_fh($fh); } - return $Fail_FH; + return $self->{Fail_FH}; } sub todo_output { my($self, $fh) = @_; if( defined $fh ) { - $Todo_FH = _new_fh($fh); + $self->{Todo_FH} = _new_fh($fh); } - return $Todo_FH; + return $self->{Todo_FH}; } @@ -1142,6 +1163,7 @@ sub _new_fh { $fh = do { local *FH }; open $fh, ">$file_or_fh" or die "Can't open test output log $file_or_fh: $!"; + _autoflush($fh); } return $fh; @@ -1169,11 +1191,10 @@ sub _autoflush { } -my $Opened_Testhandles = 0; sub _dup_stdhandles { my $self = shift; - $self->_open_testhandles unless $Opened_Testhandles; + $self->_open_testhandles; # Set everything to unbuffered else plain prints to STDOUT will # come out in the wrong order from our own prints. @@ -1182,12 +1203,15 @@ sub _dup_stdhandles { _autoflush(\*TESTERR); _autoflush(\*STDERR); - $Test->output(\*TESTOUT); - $Test->failure_output(\*TESTERR); - $Test->todo_output(\*TESTOUT); + $self->output(\*TESTOUT); + $self->failure_output(\*TESTERR); + $self->todo_output(\*TESTOUT); } + +my $Opened_Testhandles = 0; sub _open_testhandles { + 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: $!"; @@ -1220,20 +1244,21 @@ can erase history if you really want to. sub current_test { my($self, $num) = @_; - lock($Curr_Test); + lock($self->{Curr_Test}); if( defined $num ) { - unless( $Have_Plan ) { + unless( $self->{Have_Plan} ) { require Carp; Carp::croak("Can't change the current test number without a plan!"); } - $Curr_Test = $num; + $self->{Curr_Test} = $num; # If the test counter is being pushed forward fill in the details. - if( $num > @Test_Results ) { - my $start = @Test_Results ? $#Test_Results + 1 : 0; + my $test_results = $self->{Test_Results}; + if( $num > @$test_results ) { + my $start = @$test_results ? @$test_results : 0; for ($start..$num-1) { - $Test_Results[$_] = &share({ + $test_results->[$_] = &share({ 'ok' => 1, actual_ok => undef, reason => 'incrementing test number', @@ -1243,11 +1268,11 @@ sub current_test { } } # If backward, wipe history. Its their funeral. - elsif( $num < @Test_Results ) { - $#Test_Results = $num - 1; + elsif( $num < @$test_results ) { + $#{$test_results} = $num - 1; } } - return $Curr_Test; + return $self->{Curr_Test}; } @@ -1265,7 +1290,7 @@ Of course, test #1 is $tests[0], etc... sub summary { my($self) = shift; - return map { $_->{'ok'} } @Test_Results; + return map { $_->{'ok'} } @{ $self->{Test_Results} }; } =item B
@@ -1318,7 +1343,8 @@ result in this structure: =cut sub details { - return @Test_Results; + my $self = shift; + return @{ $self->{Test_Results} }; } =item B @@ -1331,9 +1357,9 @@ 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 pretty part 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. +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. Sometimes there is some confusion about where todo() should be looking for the $TODO variable. If you want to be sure, tell it explicitly @@ -1344,7 +1370,8 @@ what $pack to use. sub todo { my($self, $pack) = @_; - $pack = $pack || $self->exported_to || $self->caller(1); + $pack = $pack || $self->exported_to || $self->caller($Level); + return 0 unless $pack; no strict 'refs'; return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'} @@ -1379,7 +1406,7 @@ sub caller { =item B<_sanity_check> - _sanity_check(); + $self->_sanity_check(); Runs a bunch of end of test sanity checks to make sure reality came through ok. If anything is wrong it will die with a fairly friendly @@ -1389,10 +1416,12 @@ error message. #'# sub _sanity_check { - _whoa($Curr_Test < 0, 'Says here you ran a negative number of tests!'); - _whoa(!$Have_Plan and $Curr_Test, + my $self = shift; + + _whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!'); + _whoa(!$self->{Have_Plan} and $self->{Curr_Test}, 'Somehow your tests ran without a plan!'); - _whoa($Curr_Test != @Test_Results, + _whoa($self->{Curr_Test} != @{ $self->{Test_Results} }, 'Somehow you got a different number of results than tests ran!'); } @@ -1449,65 +1478,70 @@ $SIG{__DIE__} = sub { for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) { $in_eval = 1 if $sub =~ /^\(eval\)/; } - $Test_Died = 1 unless $in_eval; + $Test->{Test_Died} = 1 unless $in_eval; }; sub _ending { my $self = shift; - _sanity_check(); + $self->_sanity_check(); # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. - do{ _my_exit($?) && return } if $Original_Pid != $$; - - # Bailout if plan() was never called. This is so - # "require Test::Simple" doesn't puke. - do{ _my_exit(0) && return } if !$Have_Plan && !$Test_Died; + # Exit if plan() was never called. This is so "require Test::Simple" + # doesn't puke. + if( ($self->{Original_Pid} != $$) or + (!$self->{Have_Plan} && !$self->{Test_Died}) ) + { + _my_exit($?); + return; + } # Figure out if we passed or failed and print helpful messages. - if( @Test_Results ) { + my $test_results = $self->{Test_Results}; + if( @$test_results ) { # The plan? We have no plan. - if( $No_Plan ) { - $self->_print("1..$Curr_Test\n") unless $self->no_header; - $Expected_Tests = $Curr_Test; + if( $self->{No_Plan} ) { + $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header; + $self->{Expected_Tests} = $self->{Curr_Test}; } # Auto-extended arrays and elements which aren't explicitly # filled in with a shared reference will puke under 5.8.0 # ithreads. So we have to fill them in by hand. :( my $empty_result = &share({}); - for my $idx ( 0..$Expected_Tests-1 ) { - $Test_Results[$idx] = $empty_result - unless defined $Test_Results[$idx]; + for my $idx ( 0..$self->{Expected_Tests}-1 ) { + $test_results->[$idx] = $empty_result + unless defined $test_results->[$idx]; } - my $num_failed = grep !$_->{'ok'}, @Test_Results[0..$Expected_Tests-1]; - $num_failed += abs($Expected_Tests - @Test_Results); + my $num_failed = grep !$_->{'ok'}, + @{$test_results}[0..$self->{Expected_Tests}-1]; + $num_failed += abs($self->{Expected_Tests} - @$test_results); - if( $Curr_Test < $Expected_Tests ) { - my $s = $Expected_Tests == 1 ? '' : 's'; + if( $self->{Curr_Test} < $self->{Expected_Tests} ) { + my $s = $self->{Expected_Tests} == 1 ? '' : 's'; $self->diag(<<"FAIL"); -Looks like you planned $Expected_Tests test$s but only ran $Curr_Test. +Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}. FAIL } - elsif( $Curr_Test > $Expected_Tests ) { - my $num_extra = $Curr_Test - $Expected_Tests; - my $s = $Expected_Tests == 1 ? '' : 's'; + elsif( $self->{Curr_Test} > $self->{Expected_Tests} ) { + my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; + my $s = $self->{Expected_Tests} == 1 ? '' : 's'; $self->diag(<<"FAIL"); -Looks like you planned $Expected_Tests test$s but ran $num_extra extra. +Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra. FAIL } elsif ( $num_failed ) { my $s = $num_failed == 1 ? '' : 's'; $self->diag(<<"FAIL"); -Looks like you failed $num_failed test$s of $Expected_Tests. +Looks like you failed $num_failed test$s of $self->{Expected_Tests}. FAIL } - if( $Test_Died ) { + if( $self->{Test_Died} ) { $self->diag(<<"FAIL"); -Looks like your test died just after $Curr_Test. +Looks like your test died just after $self->{Curr_Test}. FAIL _my_exit( 255 ) && return; @@ -1515,10 +1549,10 @@ FAIL _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return; } - elsif ( $Skip_All ) { + elsif ( $self->{Skip_All} ) { _my_exit( 0 ) && return; } - elsif ( $Test_Died ) { + elsif ( $self->{Test_Died} ) { $self->diag(<<'FAIL'); Looks like your test died before it could output anything. FAIL