X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FTest%2FBuilder.pm;h=1a2cdb03a342443c3298948676ac1d815215336b;hb=f7c69158501ed4705d71f069f23211f56bd55a2e;hp=6f3edd8cce714ea9cf544a8b4b563129bdc34446;hpb=60ffb3081afd811893be4fb73d870ed1a5c9ca72;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Test/Builder.pm b/lib/Test/Builder.pm index 6f3edd8..1a2cdb0 100644 --- a/lib/Test/Builder.pm +++ b/lib/Test/Builder.pm @@ -1,40 +1,65 @@ 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 $CLASS); -$VERSION = '0.17'; -$CLASS = __PACKAGE__; -my $IsVMS = $^O eq 'VMS'; +our $VERSION = '0.80'; +$VERSION = eval { $VERSION }; # make the alpha version come out as a number # Make Test::Builder thread-safe for ithreads. BEGIN { use Config; - if( $] >= 5.008 && $Config{useithreads} ) { - require threads; + # Load threads::shared when threads are turned on. + # 5.8.0's threads are so busted we no longer support them. + if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'}) { require threads::shared; - threads::shared->import; + + # Hack around YET ANOTHER threads::shared bug. It would + # occassionally forget the contents of the variable when sharing it. + # So we first copy the data, then share, then put our copy back. + *share = sub (\[$@%]) { + my $type = ref $_[0]; + my $data; + + if( $type eq 'HASH' ) { + %$data = %{$_[0]}; + } + elsif( $type eq 'ARRAY' ) { + @$data = @{$_[0]}; + } + elsif( $type eq 'SCALAR' ) { + $$data = ${$_[0]}; + } + else { + die("Unknown type: ".$type); + } + + $_[0] = &threads::shared::share($_[0]); + + if( $type eq 'HASH' ) { + %{$_[0]} = %$data; + } + elsif( $type eq 'ARRAY' ) { + @{$_[0]} = @$data; + } + elsif( $type eq 'SCALAR' ) { + ${$_[0]} = $$data; + } + else { + die("Unknown type: ".$type); + } + + return $_[0]; + }; } + # 5.8.0's threads::shared is busted when threads are off + # and earlier Perls just don't have that module at all. else { - *share = sub { 0 }; + *share = sub { return $_[0] }; *lock = sub { 0 }; } } -use vars qw($Level); -my($Test_Died) = 0; -my($Have_Plan) = 0; -my $Original_Pid = $$; -my $Curr_Test = 0; share($Curr_Test); -my @Test_Results = (); share(@Test_Results); -my @Test_Details = (); share(@Test_Details); - =head1 NAME @@ -43,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); + use base 'Test::Builder::Module'; - my $Test = Test::Builder->new; - $Test->output('my_logfile'); - - sub import { - my($self) = shift; - my $pack = caller; - - $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); } @@ -86,48 +98,101 @@ 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; +my $Test = Test::Builder->new; sub new { my($class) = shift; - $Test ||= bless ['Move along, nothing to see here'], $class; + $Test ||= $class->create; return $Test; } -=back -=head2 Setting up tests +=item B -These methods are for setting up tests and declaring how many there -are. You usually only want to call one of these methods. + my $Test = Test::Builder->create; -=over 4 +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. -=item B +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. - my $pack = $Test->exported_to; - $Test->exported_to($pack); +=cut -Tells Test::Builder what package you exported your functions to. -This is important for getting TODO tests right. +sub create { + my $class = shift; + + my $self = bless {}, $class; + $self->reset; + + return $self; +} + +=item B + + $Test->reset; + +Reinitializes the Test::Builder singleton to its original state. +Mostly useful for tests run in persistent environments where the same +test might be run multiple times in the same process. =cut -my $Exported_To; -sub exported_to { - my($self, $pack) = @_; +use vars qw($Level); - if( defined $pack ) { - $Exported_To = $pack; - } - return $Exported_To; +sub reset { + my ($self) = @_; + + # 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->{Have_Plan} = 0; + $self->{No_Plan} = 0; + $self->{Original_Pid} = $$; + + share($self->{Curr_Test}); + $self->{Curr_Test} = 0; + $self->{Test_Results} = &share([]); + + $self->{Exported_To} = undef; + $self->{Expected_Tests} = 0; + + $self->{Skip_All} = 0; + + $self->{Use_Nums} = 1; + + $self->{No_Header} = 0; + $self->{No_Ending} = 0; + + $self->{TODO} = undef; + + $self->_dup_stdhandles unless $^C; + + return; } +=back + +=head2 Setting up tests + +These methods are for setting up tests and declaring how many there +are. You usually only want to call one of these methods. + +=over 4 + =item B $Test->plan('no_plan'); @@ -146,9 +211,10 @@ sub plan { return unless $cmd; - if( $Have_Plan ) { - die sprintf "You tried to plan twice! Second plan at %s line %d\n", - ($self->caller)[1,2]; + local $Level = $Level + 1; + + if( $self->{Have_Plan} ) { + $self->croak("You tried to plan twice"); } if( $cmd eq 'no_plan' ) { @@ -159,20 +225,19 @@ sub plan { } elsif( $cmd eq 'tests' ) { if( $arg ) { + local $Level = $Level + 1; return $self->expected_tests($arg); } elsif( !defined $arg ) { - die "Got an undefined number of tests. Looks like you tried to ". - "say how many tests you plan to run but made a mistake.\n"; + $self->croak("Got an undefined number of tests"); } elsif( !$arg ) { - die "You said to run 0 tests! You've got to run something.\n"; + $self->croak("You said to run 0 tests"); } } else { - require Carp; my @args = grep { defined } ($cmd, $arg); - Carp::croak("plan() doesn't understand @args"); + $self->croak("plan() doesn't understand @args"); } return 1; @@ -188,17 +253,20 @@ the appropriate headers. =cut -my $Expected_Tests = 0; sub expected_tests { - my($self, $max) = @_; + my $self = shift; + my($max) = @_; - if( defined $max ) { - $Expected_Tests = $max; - $Have_Plan = 1; + if( @_ ) { + $self->croak("Number of tests must be a positive integer. You gave it '$max'") + unless $max =~ /^\+?\d+$/ and $max > 0; + + $self->{Expected_Tests} = $max; + $self->{Have_Plan} = 1; $self->_print("1..$max\n") unless $self->no_header; } - return $Expected_Tests; + return $self->{Expected_Tests}; } @@ -210,24 +278,27 @@ Declares that this test will run an indeterminate # of tests. =cut -my($No_Plan) = 0; 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); }; @@ -240,7 +311,6 @@ Skips all the tests, using the given $reason. Exits immediately with 0. =cut -my $Skip_All = 0; sub skip_all { my($self, $reason) = @_; @@ -248,18 +318,42 @@ 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); } + +=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. @@ -281,26 +375,29 @@ sub ok { # store, so we turn it into a boolean. $test = $test ? 1 : 0; - unless( $Have_Plan ) { - require Carp; - Carp::croak("You tried to run a test without a plan! Gotta have a plan."); - } + $self->_plan_check; - 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_str(\$name); $self->diag(<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; - my $result = {}; - share($result); + my $result = &share({}); unless( $test ) { $out .= "not "; @@ -311,7 +408,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. @@ -323,9 +420,8 @@ ERR } if( $todo ) { - my $what_todo = $todo; - $out .= " # TODO $what_todo"; - $result->{reason} = $what_todo; + $out .= " # TODO $todo"; + $result->{reason} = $todo; $result->{type} = 'todo'; } else { @@ -333,19 +429,81 @@ ERR $result->{type} = ''; } - $Test_Results[$Curr_Test-1] = $result; + $self->{Test_Results}[$self->{Curr_Test}-1] = $result; $out .= "\n"; $self->_print($out); unless( $test ) { my $msg = $todo ? "Failed (TODO)" : "Failed"; - $self->diag(" $msg test ($file at line $line)\n"); + $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE}; + + 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; } + +sub _unoverload { + my $self = shift; + my $type = shift; + + $self->_try(sub { require overload } ) || return; + + foreach my $thing (@_) { + if( $self->_is_object($$thing) ) { + if( my $string_meth = overload::Method($$thing, $type) ) { + $$thing = $$thing->$string_meth(); + } + } + } +} + + +sub _is_object { + my($self, $thing) = @_; + + return $self->_try(sub { ref $thing && $thing->isa('UNIVERSAL') }) ? 1 : 0; +} + + +sub _unoverload_str { + my $self = shift; + + $self->_unoverload(q[""], @_); +} + +sub _unoverload_num { + my $self = shift; + + $self->_unoverload('0+', @_); + + for my $val (@_) { + next unless $self->_is_dualvar($$val); + $$val = $$val+0; + } +} + + +# This is a hack to detect a dualvar such as $! +sub _is_dualvar { + my($self, $val) = @_; + + local $^W = 0; + my $numval = $val+0; + return 1 if $numval != 0 and $numval ne $val; +} + + + =item B $Test->is_eq($got, $expected, $name); @@ -366,6 +524,8 @@ sub is_eq { my($self, $got, $expect, $name) = @_; local $Level = $Level + 1; + $self->_unoverload_str(\$got, \$expect); + if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; @@ -382,6 +542,8 @@ sub is_num { my($self, $got, $expect, $name) = @_; local $Level = $Level + 1; + $self->_unoverload_num(\$got, \$expect); + if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; @@ -405,7 +567,7 @@ sub _is_diag { } else { # force numeric context - $$val = $$val+0; + $self->_unoverload_num($val); } } else { @@ -413,6 +575,7 @@ sub _is_diag { } } + local $Level = $Level + 1; return $self->diag(sprintf < - $Test->is_num($got, $dont_expect, $name); + $Test->isnt_num($got, $dont_expect, $name); Like Test::More's isnt(). Checks if $got ne $dont_expect. This is the numeric version. @@ -445,7 +608,7 @@ sub isnt_eq { my $test = defined $got || defined $dont_expect; $self->ok($test, $name); - $self->_cmp_diag('ne', $got, $dont_expect) unless $test; + $self->_cmp_diag($got, 'ne', $dont_expect) unless $test; return $test; } @@ -461,7 +624,7 @@ sub isnt_num { my $test = defined $got || defined $dont_expect; $self->ok($test, $name); - $self->_cmp_diag('!=', $got, $dont_expect) unless $test; + $self->_cmp_diag($got, '!=', $dont_expect) unless $test; return $test; } @@ -502,79 +665,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; - if( ref $regex eq 'Regexp' ) { - $usable_regex = $regex; - } - # Check if it looks like '/foo/' - elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) { - $usable_regex = length $opts ? "(?$opts)$re" : $re; - }; - return($usable_regex) -}; - -sub _regex_ok { - my($self, $this, $regex, $cmp, $name) = @_; - - local $Level = $Level + 1; - - 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; - } - - { - local $^W = 0; - my $test = $this =~ /$usable_regex/ ? 1 : 0; - $test = !$test if $cmp eq '!~'; - $ok = $self->ok( $test, $name ); - } - - unless( $ok ) { - $this = defined $this ? "'$this'" : 'undef'; - my $match = $cmp eq '=~' ? "doesn't match" : "matches"; - $self->diag(sprintf < @@ -586,15 +676,33 @@ Works just like Test::More's cmp_ok(). =cut + +my %numeric_cmps = map { ($_, 1) } + ("<", "<=", ">", ">=", "==", "!=", "<=>"); + sub cmp_ok { my($self, $got, $type, $expect, $name) = @_; + # Treat overloaded objects as numbers if we're asked to do a + # numeric comparison. + my $unoverload = $numeric_cmps{$type} ? '_unoverload_num' + : '_unoverload_str'; + + $self->$unoverload(\$got, \$expect); + + my $test; { - local $^W = 0; - local($@,$!); # don't interfere with $@ - # eval() sometimes resets $! - $test = eval "\$got $type \$expect"; + 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. + # Don't ask me, man, I just work here. + $test = eval " +$code" . "\$got $type \$expect;"; + } local $Level = $Level + 1; my $ok = $self->ok($test, $name); @@ -615,6 +723,8 @@ sub _cmp_diag { $got = defined $got ? "'$got'" : 'undef'; $expect = defined $expect ? "'$expect'" : 'undef'; + + local $Level = $Level + 1; return $self->diag(sprintf < - $Test->BAILOUT($reason); +sub _caller_context { + my $self = shift; + + my($pack, $file, $line) = $self->caller(1); + + my $code = ''; + $code .= "#line $line $file\n" if defined $file and defined $line; + + 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 + + $Test->BAIL_OUT($reason); Indicates to the Test::Harness that things are going so badly all testing should terminate. This includes running any additional test @@ -634,13 +765,22 @@ It will exit with 255. =cut -sub BAILOUT { +sub BAIL_OUT { my($self, $reason) = @_; + $self->{Bailed_Out} = 1; $self->_print("Bail out! $reason"); exit 255; } +=for deprecated +BAIL_OUT() used to be BAILOUT() + +=cut + +*BAILOUT = \&BAIL_OUT; + + =item B $Test->skip; @@ -653,31 +793,28 @@ Skips the current test, reporting $why. sub skip { my($self, $why) = @_; $why ||= ''; + $self->_unoverload_str(\$why); - unless( $Have_Plan ) { - require Carp; - Carp::croak("You tried to run tests without a plan! Gotta have a plan."); - } + $self->_plan_check; - lock($Curr_Test); - $Curr_Test++; + lock($self->{Curr_Test}); + $self->{Curr_Test}++; - my %result; - share(%result); - %result = ( + $self->{Test_Results}[$self->{Curr_Test}-1] = &share({ 'ok' => 1, actual_ok => 1, name => '', type => 'skip', reason => $why, - ); - $Test_Results[$Curr_Test-1] = \%result; + }); my $out = "ok"; - $out .= " $Curr_Test" if $self->use_numbers; - $out .= " # skip $why\n"; + $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; } @@ -699,31 +836,24 @@ sub todo_skip { my($self, $why) = @_; $why ||= ''; - unless( $Have_Plan ) { - require Carp; - Carp::croak("You tried to run tests without a plan! Gotta have a plan."); - } + $self->_plan_check; - lock($Curr_Test); - $Curr_Test++; + lock($self->{Curr_Test}); + $self->{Curr_Test}++; - my %result; - share(%result); - %result = ( + $self->{Test_Results}[$self->{Curr_Test}-1] = &share({ 'ok' => 1, actual_ok => 0, name => '', type => 'todo_skip', reason => $why, - ); - - $Test_Results[$Curr_Test-1] = \%result; + }); 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; } @@ -747,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 @@ -760,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 { @@ -779,8 +1084,6 @@ sub level { return $Level; } -$CLASS->level(1); - =item B @@ -801,56 +1104,58 @@ 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 -my $Use_Nums = 1; 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 - $Test->no_header($no_header); +=item B -If set to true, no "1..N" header will be printed. + $Test->no_diag($no_diag); + +If set true no diagnostics will be printed. This includes calls to +diag(). =item B $Test->no_ending($no_ending); Normally, Test::Builder does some extra diagnostics when the test -ends. It also changes the exit code as described in Test::Simple. +ends. It also changes the exit code as described below. If this is true, none of that will be done. +=item B + + $Test->no_header($no_header); + +If set to true, no "1..N" header will be printed. + =cut -my($No_Header, $No_Ending) = (0,0); -sub no_header { - my($self, $no_header) = @_; +foreach my $attribute (qw(No_Header No_Ending No_Diag)) { + my $method = lc $attribute; - if( defined $no_header ) { - $No_Header = $no_header; - } - return $No_Header; -} + my $code = sub { + my($self, $no) = @_; -sub no_ending { - my($self, $no_ending) = @_; + if( defined $no ) { + $self->{$attribute} = $no; + } + return $self->{$attribute}; + }; - if( defined $no_ending ) { - $No_Ending = $no_ending; - } - return $No_Ending; + no strict 'refs'; ## no critic + *{__PACKAGE__.'::'.$method} = $code; } @@ -869,9 +1174,11 @@ Test::Builder's default output settings will not be affected. $Test->diag(@msgs); -Prints out the given $message. Normally, it uses the failure_output() -handle, but if this is for a TODO test, the todo_output() handle is -used. +Prints out the given @msgs. Like C, arguments are simply +appended together. + +Normally, it uses the failure_output() handle, but if this is for a +TODO test, the todo_output() handle is used. Output will be indented and marked with a # so as not to interfere with test output. A newline will be put on the end if there isn't one @@ -891,23 +1198,25 @@ Mark Fowler sub diag { my($self, @msgs) = @_; + + return if $self->no_diag; return unless @msgs; # Prevent printing headers when compiling (i.e. -c) return if $^C; + # Smash args together like print does. + # Convert undef to 'undef' so its readable. + my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs; + # Escape each line with a #. - foreach (@msgs) { - $_ = 'undef' unless defined; - s/^/# /gms; - } + $msg =~ s/^/# /gm; - push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; + # Stick a newline on the end if it needs it. + $msg .= "\n" unless $msg =~ /\n\Z/; local $Level = $Level + 1; - my $fh = $self->todo ? $self->todo_output : $self->failure_output; - local($\, $", $,) = (undef, ' ', ''); - print $fh @msgs; + $self->_print_diag($msg); return 0; } @@ -931,20 +1240,40 @@ sub _print { # tests are deparsed with B::Deparse return if $^C; + my $msg = join '', @msgs; + local($\, $", $,) = (undef, ' ', ''); my $fh = $self->output; # Escape each line after the first with a # so we don't # confuse Test::Harness. - foreach (@msgs) { - s/\n(.)/\n# $1/sg; - } + $msg =~ s/\n(.)/\n# $1/sg; - push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; + # Stick a newline on the end if it needs it. + $msg .= "\n" unless $msg =~ /\n\Z/; - print $fh @msgs; + print $fh $msg; } +=begin private + +=item B<_print_diag> + + $Test->_print_diag(@msg); + +Like _print, but prints to the current diagnostic filehandle. + +=end private + +=cut + +sub _print_diag { + my $self = shift; + + local($\, $", $,) = (undef, ' ', ''); + my $fh = $self->todo ? $self->todo_output : $self->failure_output; + print $fh @_; +} =item B @@ -975,76 +1304,151 @@ 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} = $self->_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} = $self->_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} = $self->_new_fh($fh); } - return $Todo_FH; + return $self->{Todo_FH}; } + sub _new_fh { + my $self = shift; my($file_or_fh) = shift; my $fh; - unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) { - $fh = do { local *FH }; - open $fh, ">$file_or_fh" or - die "Can't open test output log $file_or_fh: $!"; + if( $self->is_fh($file_or_fh) ) { + $fh = $file_or_fh; } else { - $fh = $file_or_fh; + open $fh, ">", $file_or_fh or + $self->croak("Can't open test output log $file_or_fh: $!"); + _autoflush($fh); } return $fh; } -unless( $^C ) { - # 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: $!"; + +sub _autoflush { + my($fh) = shift; + my $old_fh = select $fh; + $| = 1; + select $old_fh; +} + + +my($Testout, $Testerr); +sub _dup_stdhandles { + my $self = shift; + + $self->_open_testhandles; # 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); - $CLASS->output(\*TESTOUT); - $CLASS->failure_output(\*TESTERR); - $CLASS->todo_output(\*TESTOUT); + $self->output ($Testout); + $self->failure_output($Testerr); + $self->todo_output ($Testout); } -sub _autoflush { - my($fh) = shift; - my $old_fh = select $fh; - $| = 1; - select $old_fh; + +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: $!"; + +# $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); + +Warns with C<@message> but the message will appear to come from the +point where the original test function was called (C<$tb->caller>). + +=item croak + + $tb->croak(@message); + +Dies with C<@message> but the message will appear to come from the +point where the original test function was called (C<$tb->caller>). + +=cut + +sub _message_at_caller { + my $self = shift; + + local $Level = $Level + 1; + my($pack, $file, $line) = $self->caller; + return join("", @_) . " at $file line $line.\n"; +} + +sub carp { + my $self = shift; + warn $self->_message_at_caller(@_); +} + +sub croak { + my $self = shift; + die $self->_message_at_caller(@_); +} + +sub _plan_check { + my $self = shift; + + unless( $self->{Have_Plan} ) { + local $Level = $Level + 2; + $self->croak("You tried to run a test without a plan"); + } +} + =back @@ -1057,39 +1461,46 @@ sub _autoflush { my $curr_test = $Test->current_test; $Test->current_test($num); -Gets/sets the current test # we're on. +Gets/sets the current test number we're on. You usually shouldn't +have to set this. -You usually shouldn't have to set this. +If set forward, the details of the missing tests are filled in as 'unknown'. +if set backward, the details of the intervening tests are deleted. You +can erase history if you really want to. =cut sub current_test { my($self, $num) = @_; - lock($Curr_Test); + lock($self->{Curr_Test}); if( defined $num ) { - unless( $Have_Plan ) { - require Carp; - Carp::croak("Can't change the current test number without a plan!"); + unless( $self->{Have_Plan} ) { + $self->croak("Can't change the current test number without a plan!"); } - $Curr_Test = $num; - if( $num > @Test_Results ) { - my $start = @Test_Results ? $#Test_Results + 1 : 0; + $self->{Curr_Test} = $num; + + # If the test counter is being pushed forward fill in the details. + my $test_results = $self->{Test_Results}; + if( $num > @$test_results ) { + my $start = @$test_results ? @$test_results : 0; for ($start..$num-1) { - my %result; - share(%result); - %result = ( ok => 1, - actual_ok => undef, - reason => 'incrementing test number', - type => 'unknown', - name => undef - ); - $Test_Results[$_] = \%result; + $test_results->[$_] = &share({ + 'ok' => 1, + actual_ok => undef, + reason => 'incrementing test number', + type => 'unknown', + name => undef + }); } } + # If backward, wipe history. Its their funeral. + elsif( $num < @$test_results ) { + $#{$test_results} = $num - 1; + } } - return $Curr_Test; + return $self->{Curr_Test}; } @@ -1107,7 +1518,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
@@ -1160,7 +1571,8 @@ result in this structure: =cut sub details { - return @Test_Results; + my $self = shift; + return @{ $self->{Test_Results} }; } =item B @@ -1173,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 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'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 @@ -1186,9 +1599,12 @@ what $pack to use. sub todo { my($self, $pack) = @_; - $pack = $pack || $self->exported_to || $self->caller(1); + return $self->{TODO} if defined $self->{TODO}; - no strict 'refs'; + $pack = $pack || $self->caller(1) || $self->exported_to; + return 0 unless $pack; + + no strict 'refs'; ## no critic return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'} : 0; } @@ -1201,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 { @@ -1221,7 +1639,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 @@ -1231,16 +1649,18 @@ 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; + + $self->_whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!'); + $self->_whoa(!$self->{Have_Plan} and $self->{Curr_Test}, 'Somehow your tests ran without a plan!'); - _whoa($Curr_Test != @Test_Results, + $self->_whoa($self->{Curr_Test} != @{ $self->{Test_Results} }, 'Somehow you got a different number of results than tests ran!'); } =item B<_whoa> - _whoa($check, $description); + $self->_whoa($check, $description); A sanity check, similar to assert(). If the $check is true, something has gone horribly wrong. It will die with the given $description and @@ -1249,9 +1669,10 @@ a note to contact the author. =cut sub _whoa { - my($check, $desc) = @_; + my($self, $check, $desc) = @_; if( $check ) { - die <croak(<<"WHOA"); WHOA! $desc This should never happen! Please contact the author immediately! WHOA @@ -1282,86 +1703,105 @@ 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_Died = 1 unless $in_eval; -}; - sub _ending { my $self = shift; - _sanity_check(); + 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. - do{ _my_exit($?) && return } if $Original_Pid != $$; + 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; + } - # 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; + # Don't do an ending if we bailed out. + if( $self->{Bailed_Out} ) { + 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}; } - # 5.8.0 threads bug. Shared arrays will not be auto-extended - # by a slice. Worse, we have to fill in every entry else - # we'll get an "Invalid value for shared scalar" error - for my $idx ($#Test_Results..$Expected_Tests-1) { - my %empty_result = (); - share(%empty_result); - $Test_Results[$idx] = \%empty_result - unless defined $Test_Results[$idx]; + # 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..$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->{Curr_Test}-1]; + + my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; - if( $Curr_Test < $Expected_Tests ) { + if( $num_extra < 0 ) { + my $s = $self->{Expected_Tests} == 1 ? '' : 's'; $self->diag(<<"FAIL"); -Looks like you planned $Expected_Tests tests 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; + elsif( $num_extra > 0 ) { + my $s = $self->{Expected_Tests} == 1 ? '' : 's'; $self->diag(<<"FAIL"); -Looks like you planned $Expected_Tests tests but ran $num_extra extra. +Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra. FAIL } - elsif ( $num_failed ) { + + if ( $num_failed ) { + my $num_tests = $self->{Curr_Test}; + my $s = $num_failed == 1 ? '' : 's'; + + my $qualifier = $num_extra == 0 ? '' : ' run'; + $self->diag(<<"FAIL"); -Looks like you failed $num_failed tests of $Expected_Tests. +Looks like you failed $num_failed test$s of $num_tests$qualifier. FAIL } - if( $Test_Died ) { + if( $real_exit_code ) { $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; } - _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return; + my $exit_code; + if( $num_failed ) { + $exit_code = $num_failed <= 254 ? $num_failed : 254; + } + elsif( $num_extra != 0 ) { + $exit_code = 255; + } + else { + $exit_code = 0; + } + + _my_exit( $exit_code ) && return; } - elsif ( $Skip_All ) { + elsif ( $self->{Skip_All} ) { _my_exit( 0 ) && return; } - elsif ( $Test_Died ) { + elsif ( $real_exit_code ) { $self->diag(<<'FAIL'); Looks like your test died before it could output anything. FAIL + _my_exit( 255 ) && return; } else { $self->diag("No tests run!\n"); @@ -1373,12 +1813,37 @@ END { $Test->_ending if defined $Test and !$Test->no_ending; } +=head1 EXIT CODES + +If all your tests passed, Test::Builder will exit with zero (which is +normal). If anything failed it will exit with how many failed. If +you run less (or more) tests than you planned, the missing (or extras) +will be considered failures. If no tests were ever run Test::Builder +will throw a warning and exit with 255. If the test died, even after +having successfully completed all its tests, it will still be +considered a failure and will exit with 255. + +So the exit codes are... + + 0 all tests successful + 255 test died or all passed but wrong # of tests run + any other number how many failed (including missing or extras) + +If you fail more than 254 tests, it will be reported as 254. + + =head1 THREADS -In perl 5.8.0 and later, Test::Builder is thread-safe. The test +In perl 5.8.1 and later, Test::Builder is thread-safe. The test number is shared amongst all threads. This means if one thread sets the test number using current_test() they will all be effected. +While versions earlier than 5.8.1 had threads they contain too many +bugs to support. + +Test::Builder is only thread-aware if threads.pm is loaded I +Test::Builder. + =head1 EXAMPLES CPAN can provide the best examples. Test::Simple, Test::More, @@ -1395,8 +1860,8 @@ Eschwern@pobox.comE =head1 COPYRIGHT -Copyright 2002 by chromatic Echromatic@wgz.orgE, - Michael G Schwern Eschwern@pobox.comE. +Copyright 2002, 2004 by chromatic Echromatic@wgz.orgE and + Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.