X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FTest%2FBuilder.pm;h=1a2cdb03a342443c3298948676ac1d815215336b;hb=f7c69158501ed4705d71f069f23211f56bd55a2e;hp=9f6a3a43ddc13d54d872ffa47355a2c6fef42354;hpb=0257f296204adb69c838f5fbb883eb20cd264593;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Test/Builder.pm b/lib/Test/Builder.pm index 9f6a3a4..1a2cdb0 100644 --- a/lib/Test/Builder.pm +++ b/lib/Test/Builder.pm @@ -1,21 +1,17 @@ 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.22'; -$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 { use Config; - # Load threads::shared when threads are turned on - if( $] >= 5.008 && $Config{useithreads} && $INC{'threads.pm'}) { + # 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; # Hack around YET ANOTHER threads::shared bug. It would @@ -35,7 +31,7 @@ BEGIN { $$data = ${$_[0]}; } else { - die "Unknown type: ".$type; + die("Unknown type: ".$type); } $_[0] = &threads::shared::share($_[0]); @@ -50,14 +46,14 @@ BEGIN { ${$_[0]} = $$data; } else { - die "Unknown type: ".$type; + die("Unknown type: ".$type); } return $_[0]; }; } - # 5.8.0's threads::shared is busted when threads are off. - # We emulate it here. + # 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 { return $_[0] }; *lock = sub { 0 }; @@ -72,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; - - $Test->exported_to($pack); - $Test->plan(@_); + use base 'Test::Builder::Module'; - $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); } @@ -115,19 +98,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,48 +150,38 @@ 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; +sub reset { + my ($self) = @_; -my($No_Header, $No_Ending); + # 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; -$Test->reset; + $self->{Have_Plan} = 0; + $self->{No_Plan} = 0; + $self->{Original_Pid} = $$; -sub reset { - my ($self) = @_; + share($self->{Curr_Test}); + $self->{Curr_Test} = 0; + $self->{Test_Results} = &share([]); - $Test_Died = 0; - $Have_Plan = 0; - $No_Plan = 0; - $Curr_Test = 0; - $Level = 1; - $Original_Pid = $$; - @Test_Results = (); + $self->{Exported_To} = undef; + $self->{Expected_Tests} = 0; - $Exported_To = undef; - $Expected_Tests = 0; + $self->{Skip_All} = 0; - $Skip_All = 0; + $self->{Use_Nums} = 1; - $Use_Nums = 1; + $self->{No_Header} = 0; + $self->{No_Ending} = 0; - ($No_Header, $No_Ending) = (0,0); + $self->{TODO} = undef; $self->_dup_stdhandles unless $^C; - return undef; + return; } =back @@ -191,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 ) { - $Exported_To = $pack; - } - return $Exported_To; -} - =item B $Test->plan('no_plan'); @@ -228,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' ) { @@ -241,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; @@ -275,15 +258,15 @@ sub expected_tests { my($max) = @_; if( @_ ) { - die "Number of tests must be a postive integer. You gave it '$max'.\n" + $self->croak("Number of tests must be a positive integer. You gave it '$max'") 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 +279,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,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. @@ -364,26 +375,26 @@ 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(\$name); + $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(\$todo); + $self->_unoverload_str(\$todo); my $out; my $result = &share({}); @@ -397,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. @@ -418,7 +429,7 @@ ERR $result->{type} = ''; } - $Test_Results[$Curr_Test-1] = $result; + $self->{Test_Results}[$self->{Curr_Test}-1] = $result; $out .= "\n"; $self->_print($out); @@ -426,7 +437,15 @@ ERR unless( $test ) { my $msg = $todo ? "Failed (TODO)" : "Failed"; $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE}; - $self->diag(" $msg test ($file at 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; @@ -435,23 +454,56 @@ ERR sub _unoverload { my $self = shift; + my $type = shift; - local($@,$!); - - eval { require overload } || return; + $self->_try(sub { require overload } ) || return; foreach my $thing (@_) { - eval { - if( defined $$thing ) { - if( my $string_meth = overload::Method($$thing, '""') ) { - $$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($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); @@ -472,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; @@ -488,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; @@ -511,7 +567,7 @@ sub _is_diag { } else { # force numeric context - $$val = $$val+0; + $self->_unoverload_num($val); } } else { @@ -519,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. @@ -608,109 +665,44 @@ 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. +=item B -Returns a Perl value which may be used instead of the corresponding -regular expression, or undef if it's argument is not recognised. + $Test->cmp_ok($this, $type, $that, $name); -For example, a version of like(), sans the useful diagnostic messages, -could be written as: +Works just like Test::More's cmp_ok(). - 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); - } + $Test->cmp_ok($big_num, '!=', $other_big_num); =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; - } +my %numeric_cmps = map { ($_, 1) } + ("<", "<=", ">", ">=", "==", "!=", "<=>"); - return $usable_regex; -}; +sub cmp_ok { + my($self, $got, $type, $expect, $name) = @_; -sub _regex_ok { - my($self, $this, $regex, $cmp, $name) = @_; + # Treat overloaded objects as numbers if we're asked to do a + # numeric comparison. + my $unoverload = $numeric_cmps{$type} ? '_unoverload_num' + : '_unoverload_str'; - local $Level = $Level + 1; + $self->$unoverload(\$got, \$expect); - 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; { - local $^W = 0; - my $test = $this =~ /$usable_regex/ ? 1 : 0; - $test = !$test if $cmp eq '!~'; - $ok = $self->ok( $test, $name ); - } + local($@,$!,$SIG{__DIE__}); # isolate eval - unless( $ok ) { - $this = defined $this ? "'$this'" : 'undef'; - my $match = $cmp eq '=~' ? "doesn't match" : "matches"; - $self->diag(sprintf <_caller_context; -=item B - - $Test->cmp_ok($this, $type, $that, $name); + # 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;"; -Works just like Test::More's cmp_ok(). - - $Test->cmp_ok($big_num, '!=', $other_big_num); - -=cut - -sub cmp_ok { - my($self, $got, $type, $expect, $name) = @_; - - my $test; - { - local $^W = 0; - local($@,$!); # don't interfere with $@ - # eval() sometimes resets $! - $test = eval "\$got $type \$expect"; } local $Level = $Level + 1; my $ok = $self->ok($test, $name); @@ -731,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 @@ -750,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; @@ -769,17 +793,14 @@ Skips the current test, reporting $why. sub skip { my($self, $why) = @_; $why ||= ''; - $self->_unoverload(\$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}++; - $Test_Results[$Curr_Test-1] = &share({ + $self->{Test_Results}[$self->{Curr_Test}-1] = &share({ 'ok' => 1, actual_ok => 1, name => '', @@ -788,12 +809,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 +836,12 @@ 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}++; - $Test_Results[$Curr_Test-1] = &share({ + $self->{Test_Results}[$self->{Curr_Test}-1] = &share({ 'ok' => 1, actual_ok => 0, name => '', @@ -832,10 +850,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; } @@ -859,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 @@ -872,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 { @@ -911,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 @@ -921,16 +1112,18 @@ 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 @@ -941,24 +1134,28 @@ 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 -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; } @@ -1001,6 +1198,8 @@ Mark Fowler sub diag { my($self, @msgs) = @_; + + return if $self->no_diag; return unless @msgs; # Prevent printing headers when compiling (i.e. -c) @@ -1056,6 +1255,7 @@ sub _print { print $fh $msg; } +=begin private =item B<_print_diag> @@ -1063,6 +1263,8 @@ sub _print { Like _print, but prints to the current diagnostic filehandle. +=end private + =cut sub _print_diag { @@ -1102,65 +1304,52 @@ 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; - if( _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 - die "Can't open test output log $file_or_fh: $!"; + open $fh, ">", $file_or_fh or + $self->croak("Can't open test output log $file_or_fh: $!"); + _autoflush($fh); } return $fh; } -sub _is_fh { - my $maybe_fh = shift; - - 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; @@ -1169,33 +1358,97 @@ sub _autoflush { } -my $Opened_Testhandles = 0; +my($Testout, $Testerr); 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. - _autoflush(\*TESTOUT); + _autoflush($Testout); _autoflush(\*STDOUT); - _autoflush(\*TESTERR); + _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 { + 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); + +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 @@ -1220,20 +1473,20 @@ 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 ) { - 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; + $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 +1496,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 +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
@@ -1318,7 +1571,8 @@ result in this structure: =cut sub details { - return @Test_Results; + my $self = shift; + return @{ $self->{Test_Results} }; } =item B @@ -1331,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 @@ -1344,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}; + + $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; } @@ -1359,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 { @@ -1379,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 @@ -1389,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 @@ -1407,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 @@ -1440,85 +1703,101 @@ 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}; } # 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->{Curr_Test}-1]; + + my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; - if( $Curr_Test < $Expected_Tests ) { - my $s = $Expected_Tests == 1 ? '' : 's'; + if( $num_extra < 0 ) { + 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( $num_extra > 0 ) { + 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 ) { + + 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 test$s 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 @@ -1547,7 +1826,7 @@ considered a failure and will exit with 255. So the exit codes are... 0 all tests successful - 255 test died + 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. @@ -1555,10 +1834,13 @@ 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.