X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FTest%2FBuilder.pm;h=cd5779f75b66cc716d41e772dc90839b6c537bbb;hb=0508fb16c6a57ba6d246b3ddb11c79c68d302f62;hp=57a57d2a4d357d1b1a21c3730e7ab4da8c1a81d5;hpb=04955c1432b0be1ddb216b8c8dce2058e6337802;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Test/Builder.pm b/lib/Test/Builder.pm index 57a57d2..cd5779f 100644 --- a/lib/Test/Builder.pm +++ b/lib/Test/Builder.pm @@ -1,25 +1,28 @@ package Test::Builder; -use 5.004; +use 5.006; +use strict; +use warnings; -# $^C was only introduced in 5.005-ish. We do this to prevent -# use of uninitialized value warnings in older perls. -$^C ||= 0; +our $VERSION = '0.92'; +$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) + +BEGIN { + if( $] < 5.008 ) { + require Test::Builder::IO::Scalar; + } +} -use strict; -use vars qw($VERSION); -$VERSION = '0.74_1'; -$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. # 5.8.0's threads are so busted we no longer support them. - if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'}) { + if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) { require threads::shared; - # Hack around YET ANOTHER threads::shared bug. It would + # 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 (\[$@%]) { @@ -27,31 +30,31 @@ BEGIN { my $data; if( $type eq 'HASH' ) { - %$data = %{$_[0]}; + %$data = %{ $_[0] }; } elsif( $type eq 'ARRAY' ) { - @$data = @{$_[0]}; + @$data = @{ $_[0] }; } elsif( $type eq 'SCALAR' ) { - $$data = ${$_[0]}; + $$data = ${ $_[0] }; } else { - die("Unknown type: ".$type); + die( "Unknown type: " . $type ); } - $_[0] = &threads::shared::share($_[0]); + $_[0] = &threads::shared::share( $_[0] ); if( $type eq 'HASH' ) { - %{$_[0]} = %$data; + %{ $_[0] } = %$data; } elsif( $type eq 'ARRAY' ) { - @{$_[0]} = @$data; + @{ $_[0] } = @$data; } elsif( $type eq 'SCALAR' ) { - ${$_[0]} = $$data; + ${ $_[0] } = $$data; } else { - die("Unknown type: ".$type); + die( "Unknown type: " . $type ); } return $_[0]; @@ -65,7 +68,6 @@ BEGIN { } } - =head1 NAME Test::Builder - Backend for building test libraries @@ -104,7 +106,7 @@ Returns a Test::Builder object representing the current state of the test. 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 +Test::Builder object. No matter how many times you call C, you're 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. @@ -115,13 +117,13 @@ singleton, use C. =cut my $Test = Test::Builder->new; + sub new { my($class) = shift; $Test ||= $class->create; return $Test; } - =item B my $Test = Test::Builder->create; @@ -155,10 +157,10 @@ test might be run multiple times in the same process. =cut -use vars qw($Level); +our $Level; -sub reset { - my ($self) = @_; +sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms) + 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. @@ -166,25 +168,30 @@ sub reset { $self->{Have_Plan} = 0; $self->{No_Plan} = 0; + $self->{Have_Output_Plan} = 0; + $self->{Original_Pid} = $$; - share($self->{Curr_Test}); - $self->{Curr_Test} = 0; - $self->{Test_Results} = &share([]); + 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->{Skip_All} = 0; - $self->{Use_Nums} = 1; + $self->{Use_Nums} = 1; - $self->{No_Header} = 0; - $self->{No_Ending} = 0; + $self->{No_Header} = 0; + $self->{No_Ending} = 0; - $self->{TODO} = undef; + $self->{Todo} = undef; + $self->{Todo_Stack} = []; + $self->{Start_Todo} = 0; + $self->{Opened_Testhandles} = 0; - $self->_dup_stdhandles unless $^C; + $self->_dup_stdhandles; return; } @@ -207,53 +214,62 @@ are. You usually only want to call one of these methods. A convenient way to set up your tests. Call this and Test::Builder will print the appropriate headers and take the appropriate actions. -If you call plan(), don't call any of the other methods below. +If you call C, don't call any of the other methods below. =cut +my %plan_cmds = ( + no_plan => \&no_plan, + skip_all => \&skip_all, + tests => \&_plan_tests, +); + sub plan { - my($self, $cmd, $arg) = @_; + my( $self, $cmd, $arg ) = @_; return unless $cmd; local $Level = $Level + 1; - if( $self->{Have_Plan} ) { - $self->croak("You tried to plan twice"); - } + $self->croak("You tried to plan twice") if $self->{Have_Plan}; - if( $cmd eq 'no_plan' ) { - $self->no_plan; - } - elsif( $cmd eq 'skip_all' ) { - return $self->skip_all($arg); - } - elsif( $cmd eq 'tests' ) { - if( $arg ) { - local $Level = $Level + 1; - return $self->expected_tests($arg); - } - elsif( !defined $arg ) { - $self->croak("Got an undefined number of tests"); - } - elsif( !$arg ) { - $self->croak("You said to run 0 tests"); - } + if( my $method = $plan_cmds{$cmd} ) { + local $Level = $Level + 1; + $self->$method($arg); } else { - my @args = grep { defined } ($cmd, $arg); + my @args = grep { defined } ( $cmd, $arg ); $self->croak("plan() doesn't understand @args"); } return 1; } + +sub _plan_tests { + my($self, $arg) = @_; + + if($arg) { + local $Level = $Level + 1; + return $self->expected_tests($arg); + } + elsif( !defined $arg ) { + $self->croak("Got an undefined number of tests"); + } + else { + $self->croak("You said to run 0 tests"); + } + + return; +} + + =item B my $max = $Test->expected_tests; $Test->expected_tests($max); -Gets/sets the # of tests we expect this test to run and prints out +Gets/sets the number of tests we expect this test to run and prints out the appropriate headers. =cut @@ -262,74 +278,182 @@ sub expected_tests { my $self = shift; my($max) = @_; - if( @_ ) { + if(@_) { $self->croak("Number of tests must be a positive integer. You gave it '$max'") - unless $max =~ /^\+?\d+$/ and $max > 0; + unless $max =~ /^\+?\d+$/; $self->{Expected_Tests} = $max; $self->{Have_Plan} = 1; - $self->_print("1..$max\n") unless $self->no_header; + $self->_output_plan($max) unless $self->no_header; } return $self->{Expected_Tests}; } - =item B $Test->no_plan; -Declares that this test will run an indeterminate # of tests. +Declares that this test will run an indeterminate number of tests. =cut sub no_plan { - my $self = shift; + my($self, $arg) = @_; + + $self->carp("no_plan takes no arguments") if $arg; $self->{No_Plan} = 1; $self->{Have_Plan} = 1; + + return 1; +} + + +=begin private + +=item B<_output_plan> + + $tb->_output_plan($max); + $tb->_output_plan($max, $directive); + $tb->_output_plan($max, $directive => $reason); + +Handles displaying the test plan. + +If a C<$directive> and/or C<$reason> are given they will be output with the +plan. So here's what skipping all tests looks like: + + $tb->_output_plan(0, "SKIP", "Because I said so"); + +It sets C<< $tb->{Have_Output_Plan} >> and will croak if the plan was already +output. + +=end private + +=cut + +sub _output_plan { + my($self, $max, $directive, $reason) = @_; + + $self->carp("The plan was already output") if $self->{Have_Output_Plan}; + + my $plan = "1..$max"; + $plan .= " # $directive" if defined $directive; + $plan .= " $reason" if defined $reason; + + $self->_print("$plan\n"); + + $self->{Have_Output_Plan} = 1; + + return; +} + +=item B + + $Test->done_testing(); + $Test->done_testing($num_tests); + +Declares that you are done testing, no more tests will be run after this point. + +If a plan has not yet been output, it will do so. + +$num_tests is the number of tests you planned to run. If a numbered +plan was already declared, and if this contradicts, a failing test +will be run to reflect the planning mistake. If C was declared, +this will override. + +If C is called twice, the second call will issue a +failing test. + +If C<$num_tests> is omitted, the number of tests run will be used, like +no_plan. + +C is, in effect, used when you'd want to use C, but +safer. You'd use it like so: + + $Test->ok($a == $b); + $Test->done_testing(); + +Or to plan a variable number of tests: + + for my $test (@tests) { + $Test->ok($test); + } + $Test->done_testing(@tests); + +=cut + +sub done_testing { + my($self, $num_tests) = @_; + + # If done_testing() specified the number of tests, shut off no_plan. + if( defined $num_tests ) { + $self->{No_Plan} = 0; + } + else { + $num_tests = $self->current_test; + } + + if( $self->{Done_Testing} ) { + my($file, $line) = @{$self->{Done_Testing}}[1,2]; + $self->ok(0, "done_testing() was already called at $file line $line"); + return; + } + + $self->{Done_Testing} = [caller]; + + if( $self->expected_tests && $num_tests != $self->expected_tests ) { + $self->ok(0, "planned to run @{[ $self->expected_tests ]} ". + "but done_testing() expects $num_tests"); + } + else { + $self->{Expected_Tests} = $num_tests; + } + + $self->_output_plan($num_tests) unless $self->{Have_Output_Plan}; + + $self->{Have_Plan} = 1; + + return 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). +Find out whether a plan has been defined. C<$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 { my $self = shift; - return($self->{Expected_Tests}) if $self->{Expected_Tests}; + return( $self->{Expected_Tests} ) if $self->{Expected_Tests}; return('no_plan') if $self->{No_Plan}; return(undef); -}; - +} =item B $Test->skip_all; $Test->skip_all($reason); -Skips all the tests, using the given $reason. Exits immediately with 0. +Skips all the tests, using the given C<$reason>. Exits immediately with 0. =cut sub skip_all { - my($self, $reason) = @_; - - my $out = "1..0"; - $out .= " # Skip $reason" if $reason; - $out .= "\n"; + my( $self, $reason ) = @_; $self->{Skip_All} = 1; - $self->_print($out) unless $self->no_header; + $self->_output_plan(0, "SKIP", $reason) unless $self->no_header; exit(0); } - =item B my $pack = $Test->exported_to; @@ -344,7 +468,7 @@ the last one will be honored. =cut sub exported_to { - my($self, $pack) = @_; + my( $self, $pack ) = @_; if( defined $pack ) { $self->{Exported_To} = $pack; @@ -360,7 +484,7 @@ 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. +C<$name> is always optional. =over 4 @@ -368,45 +492,43 @@ $name is always optional. $Test->ok($test, $name); -Your basic test. Pass if $test is true, fail if $test is false. Just -like Test::Simple's ok(). +Your basic test. Pass if C<$test> is true, fail if $test is false. Just +like Test::Simple's C. =cut sub ok { - my($self, $test, $name) = @_; + my( $self, $test, $name ) = @_; # $test might contain an object which we don't want to accidentally # store, so we turn it into a boolean. $test = $test ? 1 : 0; - $self->_plan_check; - lock $self->{Curr_Test}; $self->{Curr_Test}++; # In case $name is a string overloaded object, force it to stringify. - $self->_unoverload_str(\$name); + $self->_unoverload_str( \$name ); - $self->diag(<diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/; You named your test '$name'. You shouldn't use numbers for your test names. Very confusing. ERR - 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(); + my $in_todo = $self->in_todo; + local $self->{Todo} = $todo if $in_todo; - $self->_unoverload_str(\$todo); + $self->_unoverload_str( \$todo ); my $out; - my $result = &share({}); + my $result = &share( {} ); - unless( $test ) { + unless($test) { $out .= "not "; - @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 ); + @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 ); } else { @$result{ 'ok', 'actual_ok' } = ( 1, $test ); @@ -416,16 +538,16 @@ ERR $out .= " $self->{Curr_Test}" if $self->use_numbers; if( defined $name ) { - $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. - $out .= " - $name"; + $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. + $out .= " - $name"; $result->{name} = $name; } else { $result->{name} = ''; } - if( $todo ) { - $out .= " # TODO $todo"; + if( $self->in_todo ) { + $out .= " # TODO $todo"; $result->{reason} = $todo; $result->{type} = 'todo'; } @@ -434,16 +556,16 @@ ERR $result->{type} = ''; } - $self->{Test_Results}[$self->{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->_print_diag("\n") if $ENV{HARNESS_ACTIVE}; + unless($test) { + my $msg = $self->in_todo ? "Failed (TODO)" : "Failed"; + $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE}; - my(undef, $file, $line) = $self->caller; + my( undef, $file, $line ) = $self->caller; if( defined $name ) { $self->diag(qq[ $msg test '$name'\n]); $self->diag(qq[ at $file line $line.\n]); @@ -451,297 +573,324 @@ ERR else { $self->diag(qq[ $msg test at $file line $line.\n]); } - } + } return $test ? 1 : 0; } - sub _unoverload { - my $self = shift; - my $type = shift; + my $self = shift; + my $type = shift; - $self->_try(sub { require overload } ) || return; + $self->_try(sub { require overload; }, die_on_fail => 1); foreach my $thing (@_) { if( $self->_is_object($$thing) ) { - if( my $string_meth = overload::Method($$thing, $type) ) { + if( my $string_meth = overload::Method( $$thing, $type ) ) { $$thing = $$thing->$string_meth(); } } } -} + return; +} sub _is_object { - my($self, $thing) = @_; + my( $self, $thing ) = @_; - return $self->_try(sub { ref $thing && $thing->isa('UNIVERSAL') }) ? 1 : 0; + return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0; } - sub _unoverload_str { my $self = shift; - $self->_unoverload(q[""], @_); -} + return $self->_unoverload( q[""], @_ ); +} sub _unoverload_num { my $self = shift; - $self->_unoverload('0+', @_); + $self->_unoverload( '0+', @_ ); for my $val (@_) { next unless $self->_is_dualvar($$val); - $$val = $$val+0; + $$val = $$val + 0; } -} + return; +} # 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; -} + my( $self, $val ) = @_; + # Objects are not dualvars. + return 0 if ref $val; + no warnings 'numeric'; + my $numval = $val + 0; + return $numval != 0 and $numval ne $val ? 1 : 0; +} =item B $Test->is_eq($got, $expected, $name); -Like Test::More's is(). Checks if $got eq $expected. This is the +Like Test::More's C. Checks if C<$got eq $expected>. This is the string version. =item B $Test->is_num($got, $expected, $name); -Like Test::More's is(). Checks if $got == $expected. This is the +Like Test::More's C. Checks if C<$got == $expected>. This is the numeric version. =cut sub is_eq { - my($self, $got, $expect, $name) = @_; + my( $self, $got, $expect, $name ) = @_; local $Level = $Level + 1; - $self->_unoverload_str(\$got, \$expect); + $self->_unoverload_str( \$got, \$expect ); if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; - $self->ok($test, $name); - $self->_is_diag($got, 'eq', $expect) unless $test; + $self->ok( $test, $name ); + $self->_is_diag( $got, 'eq', $expect ) unless $test; return $test; } - return $self->cmp_ok($got, 'eq', $expect, $name); + return $self->cmp_ok( $got, 'eq', $expect, $name ); } sub is_num { - my($self, $got, $expect, $name) = @_; + my( $self, $got, $expect, $name ) = @_; local $Level = $Level + 1; - $self->_unoverload_num(\$got, \$expect); + $self->_unoverload_num( \$got, \$expect ); if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; - $self->ok($test, $name); - $self->_is_diag($got, '==', $expect) unless $test; + $self->ok( $test, $name ); + $self->_is_diag( $got, '==', $expect ) unless $test; return $test; } - return $self->cmp_ok($got, '==', $expect, $name); + return $self->cmp_ok( $got, '==', $expect, $name ); } -sub _is_diag { - my($self, $got, $type, $expect) = @_; +sub _diag_fmt { + my( $self, $type, $val ) = @_; - foreach my $val (\$got, \$expect) { - if( defined $$val ) { - if( $type eq 'eq' ) { - # quote and force string context - $$val = "'$$val'" - } - else { - # force numeric context - $self->_unoverload_num($val); - } + if( defined $$val ) { + if( $type eq 'eq' or $type eq 'ne' ) { + # quote and force string context + $$val = "'$$val'"; } else { - $$val = 'undef'; + # force numeric context + $self->_unoverload_num($val); } } + else { + $$val = 'undef'; + } + + return; +} + +sub _is_diag { + my( $self, $got, $type, $expect ) = @_; + + $self->_diag_fmt( $type, $_ ) for \$got, \$expect; local $Level = $Level + 1; - return $self->diag(sprintf <diag(<<"DIAGNOSTIC"); + got: $got + expected: $expect DIAGNOSTIC -} +} + +sub _isnt_diag { + my( $self, $got, $type ) = @_; + + $self->_diag_fmt( $type, \$got ); + + local $Level = $Level + 1; + return $self->diag(<<"DIAGNOSTIC"); + got: $got + expected: anything else +DIAGNOSTIC +} =item B $Test->isnt_eq($got, $dont_expect, $name); -Like Test::More's isnt(). Checks if $got ne $dont_expect. This is +Like Test::More's C. Checks if C<$got ne $dont_expect>. This is the string version. =item B $Test->isnt_num($got, $dont_expect, $name); -Like Test::More's isnt(). Checks if $got ne $dont_expect. This is +Like Test::More's C. Checks if C<$got ne $dont_expect>. This is the numeric version. =cut sub isnt_eq { - my($self, $got, $dont_expect, $name) = @_; + my( $self, $got, $dont_expect, $name ) = @_; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { # undef only matches undef and nothing else my $test = defined $got || defined $dont_expect; - $self->ok($test, $name); - $self->_cmp_diag($got, 'ne', $dont_expect) unless $test; + $self->ok( $test, $name ); + $self->_isnt_diag( $got, 'ne' ) unless $test; return $test; } - return $self->cmp_ok($got, 'ne', $dont_expect, $name); + return $self->cmp_ok( $got, 'ne', $dont_expect, $name ); } sub isnt_num { - my($self, $got, $dont_expect, $name) = @_; + my( $self, $got, $dont_expect, $name ) = @_; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { # undef only matches undef and nothing else my $test = defined $got || defined $dont_expect; - $self->ok($test, $name); - $self->_cmp_diag($got, '!=', $dont_expect) unless $test; + $self->ok( $test, $name ); + $self->_isnt_diag( $got, '!=' ) unless $test; return $test; } - return $self->cmp_ok($got, '!=', $dont_expect, $name); + return $self->cmp_ok( $got, '!=', $dont_expect, $name ); } - =item B $Test->like($this, qr/$regex/, $name); $Test->like($this, '/$regex/', $name); -Like Test::More's like(). Checks if $this matches the given $regex. +Like Test::More's C. Checks if $this matches the given C<$regex>. -You'll want to avoid qr// if you want your tests to work before 5.005. +You'll want to avoid C if you want your tests to work before 5.005. =item B $Test->unlike($this, qr/$regex/, $name); $Test->unlike($this, '/$regex/', $name); -Like Test::More's unlike(). Checks if $this B the -given $regex. +Like Test::More's C. Checks if $this B the +given C<$regex>. =cut sub like { - my($self, $this, $regex, $name) = @_; + my( $self, $this, $regex, $name ) = @_; local $Level = $Level + 1; - $self->_regex_ok($this, $regex, '=~', $name); + return $self->_regex_ok( $this, $regex, '=~', $name ); } sub unlike { - my($self, $this, $regex, $name) = @_; + my( $self, $this, $regex, $name ) = @_; local $Level = $Level + 1; - $self->_regex_ok($this, $regex, '!~', $name); + return $self->_regex_ok( $this, $regex, '!~', $name ); } - =item B $Test->cmp_ok($this, $type, $that, $name); -Works just like Test::More's cmp_ok(). +Works just like Test::More's C. $Test->cmp_ok($big_num, '!=', $other_big_num); =cut - -my %numeric_cmps = map { ($_, 1) } - ("<", "<=", ">", ">=", "==", "!=", "<=>"); +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( $self, $got, $type, $expect, $name ) = @_; my $test; + my $error; { - local($@,$!,$SIG{__DIE__}); # isolate eval + ## no critic (BuiltinFunctions::ProhibitStringyEval) - 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" . "\$got $type \$expect;"; + my($pack, $file, $line) = $self->caller(); + $test = eval qq[ +#line 1 "cmp_ok [from $file line $line]" +\$got $type \$expect; +]; + $error = $@; } local $Level = $Level + 1; - my $ok = $self->ok($test, $name); + my $ok = $self->ok( $test, $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->diag(<<"END") if $error; +An error occurred while using $type: +------------------------------------ +$error +------------------------------------ +END + + unless($ok) { + $self->$unoverload( \$got, \$expect ); - unless( $ok ) { if( $type =~ /^(eq|==)$/ ) { - $self->_is_diag($got, $type, $expect); + $self->_is_diag( $got, $type, $expect ); + } + elsif( $type =~ /^(ne|!=)$/ ) { + $self->_isnt_diag( $got, $type ); } else { - $self->_cmp_diag($got, $type, $expect); + $self->_cmp_diag( $got, $type, $expect ); } } return $ok; } sub _cmp_diag { - my($self, $got, $type, $expect) = @_; - + my( $self, $got, $type, $expect ) = @_; + $got = defined $got ? "'$got'" : 'undef'; $expect = defined $expect ? "'$expect'" : 'undef'; - + local $Level = $Level + 1; - return $self->diag(sprintf <diag(<<"DIAGNOSTIC"); + $got + $type + $expect DIAGNOSTIC } - sub _caller_context { my $self = shift; - my($pack, $file, $line) = $self->caller(1); + my( $pack, $file, $line ) = $self->caller(1); my $code = ''; $code .= "#line $line $file\n" if defined $file and defined $line; @@ -771,7 +920,7 @@ It will exit with 255. =cut sub BAIL_OUT { - my($self, $reason) = @_; + my( $self, $reason ) = @_; $self->{Bailed_Out} = 1; $self->_print("Bail out! $reason"); @@ -785,52 +934,50 @@ BAIL_OUT() used to be BAILOUT() *BAILOUT = \&BAIL_OUT; - =item B $Test->skip; $Test->skip($why); -Skips the current test, reporting $why. +Skips the current test, reporting C<$why>. =cut sub skip { - my($self, $why) = @_; + my( $self, $why ) = @_; $why ||= ''; - $self->_unoverload_str(\$why); + $self->_unoverload_str( \$why ); - $self->_plan_check; - - lock($self->{Curr_Test}); + lock( $self->{Curr_Test} ); $self->{Curr_Test}++; - $self->{Test_Results}[$self->{Curr_Test}-1] = &share({ - 'ok' => 1, - actual_ok => 1, - name => '', - type => 'skip', - reason => $why, - }); + $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share( + { + 'ok' => 1, + actual_ok => 1, + name => '', + type => 'skip', + reason => $why, + } + ); my $out = "ok"; - $out .= " $self->{Curr_Test}" if $self->use_numbers; - $out .= " # skip"; - $out .= " $why" if length $why; - $out .= "\n"; + $out .= " $self->{Curr_Test}" if $self->use_numbers; + $out .= " # skip"; + $out .= " $why" if length $why; + $out .= "\n"; $self->_print($out); return 1; } - =item B $Test->todo_skip; $Test->todo_skip($why); -Like skip(), only it will declare the test as failing and TODO. Similar +Like C, only it will declare the test as failing and TODO. Similar to print "not ok $tnum # TODO $why\n"; @@ -838,32 +985,31 @@ to =cut sub todo_skip { - my($self, $why) = @_; + my( $self, $why ) = @_; $why ||= ''; - $self->_plan_check; - - lock($self->{Curr_Test}); + lock( $self->{Curr_Test} ); $self->{Curr_Test}++; - $self->{Test_Results}[$self->{Curr_Test}-1] = &share({ - 'ok' => 1, - actual_ok => 0, - name => '', - type => 'todo_skip', - reason => $why, - }); + $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share( + { + 'ok' => 1, + actual_ok => 0, + name => '', + type => 'todo_skip', + reason => $why, + } + ); my $out = "not ok"; - $out .= " $self->{Curr_Test}" if $self->use_numbers; - $out .= " # TODO & SKIP $why\n"; + $out .= " $self->{Curr_Test}" if $self->use_numbers; + $out .= " # TODO & SKIP $why\n"; $self->_print($out); return 1; } - =begin _unimplemented =item B @@ -871,10 +1017,10 @@ sub todo_skip { $Test->skip_rest; $Test->skip_rest($reason); -Like skip(), only it skips all the rest of the tests you plan to run +Like C, only it skips all the rest of the tests you plan to run and terminates the test. -If you're running under no_plan, it skips once and terminates the +If you're running under C, it skips once and terminates the test. =end _unimplemented @@ -896,13 +1042,13 @@ These methods are useful when writing your own test methods. 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 +Takes a quoted regular expression produced by C, 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. +regular expression, or C if its argument is not recognised. -For example, a version of like(), sans the useful diagnostic messages, +For example, a version of C, sans the useful diagnostic messages, could be written as: sub laconic_like { @@ -915,27 +1061,22 @@ could be written as: =cut - sub maybe_regex { - my ($self, $regex) = @_; + my( $self, $regex ) = @_; my $usable_regex = undef; return $usable_regex unless defined $regex; - my($re, $opts); + my( $re, $opts ); # Check for qr/foo/ - if ( $] >= 5.009004 - ? re::is_regexp($regex) - : ref $regex eq 'Regexp' - ) - { + 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 - ) + 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; } @@ -943,35 +1084,36 @@ sub maybe_regex { 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( $self, $this, $regex, $cmp, $name ) = @_; - my $ok = 0; + my $ok = 0; my $usable_regex = $self->maybe_regex($regex); - unless (defined $usable_regex) { + unless( defined $usable_regex ) { + local $Level = $Level + 1; $ok = $self->ok( 0, $name ); $self->diag(" '$regex' doesn't look much like a regex to me."); return $ok; } { + ## no critic (BuiltinFunctions::ProhibitStringyEval) + my $test; my $code = $self->_caller_context; - local($@, $!, $SIG{__DIE__}); # isolate eval + local( $@, $!, $SIG{__DIE__} ); # isolate eval - # Yes, it has to look like this or 5.4.5 won't see the #line + # 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 " @@ -983,12 +1125,12 @@ $code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0}; $ok = $self->ok( $test, $name ); } - unless( $ok ) { + unless($ok) { $this = defined $this ? "'$this'" : 'undef'; my $match = $cmp eq '=~' ? "doesn't match" : "matches"; local $Level = $Level + 1; - $self->diag(sprintf <diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex ); %s %13s '%s' DIAGNOSTIC @@ -998,7 +1140,6 @@ DIAGNOSTIC return $ok; } - # I'm not ready to publish this. It doesn't deal with array return # values from the code or context. @@ -1009,23 +1150,33 @@ DIAGNOSTIC 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. +Works like eval BLOCK except it ensures it has no effect on the rest +of the test (ie. C<$@> is not set) nor is effected by outside +interference (ie. C<$SIG{__DIE__}>) and works around some quirks in older +Perls. -$error is what would normally be in $@. +C<$error> is what would normally be in C<$@>. 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; + my( $self, $code, %opts ) = @_; + + my $error; + my $return; + { + local $!; # eval can mess up $! + local $@; # don't set $@ in the test + local $SIG{__DIE__}; # don't trip an outside DIE handler. + $return = eval { $code->() }; + $error = $@; + } + + die $error if $error and $opts{die_on_fail}; + + return wantarray ? ( $return, $error ) : $return; } =end private @@ -1035,24 +1186,23 @@ sub _try { my $is_fh = $Test->is_fh($thing); -Determines if the given $thing can be used as a filehandle. +Determines if the given C<$thing> can be used as a filehandle. =cut sub is_fh { - my $self = shift; + 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 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') }; + eval { ( tied($maybe_fh) || '' )->can('TIEHANDLE') }; } - =back @@ -1065,7 +1215,7 @@ sub is_fh { $Test->level($how_high); -How far up the call stack should $Test look when reporting where the +How far up the call stack should C<$Test> look when reporting where the test failed. Defaults to 1. @@ -1085,7 +1235,7 @@ To be polite to other functions wrapping your own you usually want to increment =cut sub level { - my($self, $level) = @_; + my( $self, $level ) = @_; if( defined $level ) { $Level = $level; @@ -1093,7 +1243,6 @@ sub level { return $Level; } - =item B $Test->use_numbers($on_or_off); @@ -1118,7 +1267,7 @@ Defaults to on. =cut sub use_numbers { - my($self, $use_nums) = @_; + my( $self, $use_nums ) = @_; if( defined $use_nums ) { $self->{Use_Nums} = $use_nums; @@ -1126,13 +1275,12 @@ sub use_numbers { return $self->{Use_Nums}; } - =item B $Test->no_diag($no_diag); If set true no diagnostics will be printed. This includes calls to -diag(). +C. =item B @@ -1155,7 +1303,7 @@ foreach my $attribute (qw(No_Header No_Ending No_Diag)) { my $method = lc $attribute; my $code = sub { - my($self, $no) = @_; + my( $self, $no ) = @_; if( defined $no ) { $self->{$attribute} = $no; @@ -1163,11 +1311,10 @@ foreach my $attribute (qw(No_Header No_Ending No_Diag)) { return $self->{$attribute}; }; - no strict 'refs'; ## no critic - *{__PACKAGE__.'::'.$method} = $code; + no strict 'refs'; ## no critic + *{ __PACKAGE__ . '::' . $method } = $code; } - =back =head2 Output @@ -1183,11 +1330,11 @@ Test::Builder's default output settings will not be affected. $Test->diag(@msgs); -Prints out the given @msgs. Like C, arguments are simply +Prints out the given C<@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. +Normally, it uses the C handle, but if this is for a +TODO test, the C 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 @@ -1195,7 +1342,7 @@ already. We encourage using this rather than calling print directly. -Returns false. Why? Because diag() is often used in conjunction with +Returns false. Why? Because C is often used in conjunction with a failing test (C) it "passes through" the failure. return ok(...) || diag(...); @@ -1206,7 +1353,35 @@ Mark Fowler =cut sub diag { - my($self, @msgs) = @_; + my $self = shift; + + $self->_print_comment( $self->_diag_fh, @_ ); +} + +=item B + + $Test->note(@msgs); + +Like C, but it prints to the C handle so it will not +normally be seen by the user except in verbose mode. + +=cut + +sub note { + my $self = shift; + + $self->_print_comment( $self->output, @_ ); +} + +sub _diag_fh { + my $self = shift; + + local $Level = $Level + 1; + return $self->in_todo ? $self->todo_output : $self->failure_output; +} + +sub _print_comment { + my( $self, $fh, @msgs ) = @_; return if $self->no_diag; return unless @msgs; @@ -1218,32 +1393,66 @@ sub diag { # Convert undef to 'undef' so its readable. my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs; - # Escape each line with a #. - $msg =~ s/^/# /gm; - - # Stick a newline on the end if it needs it. - $msg .= "\n" unless $msg =~ /\n\Z/; + # Escape the beginning, _print will take care of the rest. + $msg =~ s/^/# /; local $Level = $Level + 1; - $self->_print_diag($msg); + $self->_print_to_fh( $fh, $msg ); return 0; } +=item B + + my @dump = $Test->explain(@msgs); + +Will dump the contents of any references in a human readable format. +Handy for things like... + + is_deeply($have, $want) || diag explain $have; + +or + + is_deeply($have, $want) || note explain $have; + +=cut + +sub explain { + my $self = shift; + + return map { + ref $_ + ? do { + $self->_try(sub { require Data::Dumper }, die_on_fail => 1); + + my $dumper = Data::Dumper->new( [$_] ); + $dumper->Indent(1)->Terse(1); + $dumper->Sortkeys(1) if $dumper->can("Sortkeys"); + $dumper->Dump; + } + : $_ + } @_; +} + =begin _private =item B<_print> $Test->_print(@msgs); -Prints to the output() filehandle. +Prints to the C filehandle. =end _private =cut sub _print { - my($self, @msgs) = @_; + my $self = shift; + return $self->_print_to_fh( $self->output, @_ ); +} + +sub _print_to_fh { + my( $self, $fh, @msgs ) = @_; # Prevent printing headers when only compiling. Mostly for when # tests are deparsed with B::Deparse @@ -1251,70 +1460,53 @@ sub _print { my $msg = join '', @msgs; - local($\, $", $,) = (undef, ' ', ''); - my $fh = $self->output; + local( $\, $", $, ) = ( undef, ' ', '' ); # Escape each line after the first with a # so we don't # confuse Test::Harness. - $msg =~ s/\n(.)/\n# $1/sg; + $msg =~ s{\n(?!\z)}{\n# }sg; # Stick a newline on the end if it needs it. - $msg .= "\n" unless $msg =~ /\n\Z/; + $msg .= "\n" unless $msg =~ /\n\z/; - print $fh $msg; + return 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 +=item B -sub _print_diag { - my $self = shift; +=item B - local($\, $", $,) = (undef, ' ', ''); - my $fh = $self->todo ? $self->todo_output : $self->failure_output; - print $fh @_; -} +=item B -=item B + my $filehandle = $Test->output; + $Test->output($filehandle); + $Test->output($filename); + $Test->output(\$scalar); - $Test->output($fh); - $Test->output($file); +These methods control where Test::Builder will print its output. +They take either an open C<$filehandle>, a C<$filename> to open and write to +or a C<$scalar> reference to append to. It will always return a C<$filehandle>. -Where normal "ok/not ok" test output should go. +B is where normal "ok/not ok" test output goes. Defaults to STDOUT. -=item B - - $Test->failure_output($fh); - $Test->failure_output($file); - -Where diagnostic output on test failures and diag() should go. +B is where diagnostic output on test failures and +C goes. It is normally not read by Test::Harness and instead is +displayed to the user. Defaults to STDERR. -=item B - - $Test->todo_output($fh); - $Test->todo_output($file); - -Where diagnostics about todo test failures and diag() should go. +C is used instead of C for the +diagnostics of a failing TODO test. These will not be seen by the +user. Defaults to STDOUT. =cut sub output { - my($self, $fh) = @_; + my( $self, $fh ) = @_; if( defined $fh ) { $self->{Out_FH} = $self->_new_fh($fh); @@ -1323,7 +1515,7 @@ sub output { } sub failure_output { - my($self, $fh) = @_; + my( $self, $fh ) = @_; if( defined $fh ) { $self->{Fail_FH} = $self->_new_fh($fh); @@ -1332,7 +1524,7 @@ sub failure_output { } sub todo_output { - my($self, $fh) = @_; + my( $self, $fh ) = @_; if( defined $fh ) { $self->{Todo_FH} = $self->_new_fh($fh); @@ -1340,7 +1532,6 @@ sub todo_output { return $self->{Todo_FH}; } - sub _new_fh { my $self = shift; my($file_or_fh) = shift; @@ -1349,25 +1540,38 @@ sub _new_fh { if( $self->is_fh($file_or_fh) ) { $fh = $file_or_fh; } + elsif( ref $file_or_fh eq 'SCALAR' ) { + # Scalar refs as filehandles was added in 5.8. + if( $] >= 5.008 ) { + open $fh, ">>", $file_or_fh + or $self->croak("Can't open scalar ref $file_or_fh: $!"); + } + # Emulate scalar ref filehandles with a tie. + else { + $fh = Test::Builder::IO::Scalar->new($file_or_fh) + or $self->croak("Can't tie scalar ref $file_or_fh"); + } + } else { - open $fh, ">", $file_or_fh or - $self->croak("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 _autoflush { my($fh) = shift; my $old_fh = select $fh; $| = 1; select $old_fh; + + return; } +my( $Testout, $Testerr ); -my($Testout, $Testerr); sub _dup_stdhandles { my $self = shift; @@ -1376,43 +1580,64 @@ sub _dup_stdhandles { # Set everything to unbuffered else plain prints to STDOUT will # come out in the wrong order from our own prints. _autoflush($Testout); - _autoflush(\*STDOUT); + _autoflush( \*STDOUT ); _autoflush($Testerr); - _autoflush(\*STDERR); + _autoflush( \*STDERR ); - $self->output ($Testout); - $self->failure_output($Testerr); - $self->todo_output ($Testout); -} + $self->reset_outputs; + return; +} -my $Opened_Testhandles = 0; sub _open_testhandles { my $self = shift; - - return if $Opened_Testhandles; - + + return if $self->{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; -} + # $self->_copy_io_layers( \*STDOUT, $Testout ); + # $self->_copy_io_layers( \*STDERR, $Testerr ); + $self->{Opened_Testhandles} = 1; + + return; +} sub _copy_io_layers { - my($self, $src, $dest) = @_; - - $self->_try(sub { - require PerlIO; - my @layers = PerlIO::get_layers($src); - - binmode $dest, join " ", map ":$_", @layers if @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; + } + ); + + return; +} + +=item reset_outputs + + $tb->reset_outputs; + +Resets all the output filehandles back to their defaults. + +=cut + +sub reset_outputs { + my $self = shift; + + $self->output ($Testout); + $self->failure_output($Testerr); + $self->todo_output ($Testout); + + return; } =item carp @@ -1420,14 +1645,14 @@ sub _copy_io_layers { $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>). +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>). +point where the original test function was called (C<< $tb->caller >>). =cut @@ -1435,28 +1660,20 @@ sub _message_at_caller { my $self = shift; local $Level = $Level + 1; - my($pack, $file, $line) = $self->caller; - return join("", @_) . " at $file line $line.\n"; + my( $pack, $file, $line ) = $self->caller; + return join( "", @_ ) . " at $file line $line.\n"; } sub carp { my $self = shift; - warn $self->_message_at_caller(@_); + return warn $self->_message_at_caller(@_); } sub croak { my $self = shift; - die $self->_message_at_caller(@_); + return 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 @@ -1480,28 +1697,26 @@ can erase history if you really want to. =cut sub current_test { - my($self, $num) = @_; + my( $self, $num ) = @_; - lock($self->{Curr_Test}); + lock( $self->{Curr_Test} ); if( defined $num ) { - unless( $self->{Have_Plan} ) { - $self->croak("Can't change the current test number without a plan!"); - } - $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) { - $test_results->[$_] = &share({ - 'ok' => 1, - actual_ok => undef, - reason => 'incrementing test number', - type => 'unknown', - name => undef - }); + for( $start .. $num - 1 ) { + $test_results->[$_] = &share( + { + 'ok' => 1, + actual_ok => undef, + reason => 'incrementing test number', + type => 'unknown', + name => undef + } + ); } } # If backward, wipe history. Its their funeral. @@ -1512,7 +1727,6 @@ sub current_test { return $self->{Curr_Test}; } - =item B my @tests = $Test->summary; @@ -1534,7 +1748,7 @@ sub summary { my @tests = $Test->details; -Like summary(), but with a lot more detail. +Like C, but with a lot more detail. $tests[$test_num - 1] = { 'ok' => is the test considered a pass? @@ -1548,7 +1762,7 @@ Like summary(), but with a lot more detail. 'actual_ok' is a reflection of whether or not the test literally printed 'ok' or 'not ok'. This is for examining the result of 'todo' -tests. +tests. 'name' is the name of the test. @@ -1561,16 +1775,16 @@ of ''. Type can be one of the following: unknown see below Sometimes the Test::Builder test counter is incremented without it -printing any test output, for example, when current_test() is changed. +printing any test output, for example, when C is changed. In these cases, Test::Builder doesn't know the result of the test, so -it's type is 'unkown'. These details for these tests are filled in. -They are considered ok, but the name and actual_ok is left undef. +its type is 'unknown'. These details for these tests are filled in. +They are considered ok, but the name and actual_ok is left C. For example "not ok 23 - hole count # TODO insufficient donuts" would result in this structure: $tests[22] = # 23 - 1, since arrays start from 0. - { ok => 1, # logically, the test passed since it's todo + { ok => 1, # logically, the test passed since its todo actual_ok => 0, # in absolute terms, it failed name => 'hole count', type => 'todo', @@ -1589,33 +1803,154 @@ sub details { my $todo_reason = $Test->todo; my $todo_reason = $Test->todo($pack); -todo() looks for a $TODO variable in your tests. If set, all tests -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. +If the current tests are considered "TODO" it will return the reason, +if any. This reason can come from a C<$TODO> variable or the last call +to C. + +Since a TODO test does not need a reason, this function can return an +empty string even when inside a TODO block. Use C<< $Test->in_todo >> +to determine if you are currently inside a TODO block. -todo() is about finding the right package to look for $TODO in. It's +C is about finding the right package to look for C<$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 +for the C<$TODO> variable. If you want to be sure, tell it explicitly what $pack to use. =cut sub todo { - my($self, $pack) = @_; + my( $self, $pack ) = @_; - return $self->{TODO} if defined $self->{TODO}; + return $self->{Todo} if defined $self->{Todo}; + + local $Level = $Level + 1; + my $todo = $self->find_TODO($pack); + return $todo if defined $todo; + + return ''; +} + +=item B + + my $todo_reason = $Test->find_TODO(); + my $todo_reason = $Test->find_TODO($pack): + +Like C but only returns the value of C<$TODO> ignoring +C. + +=cut + +sub find_TODO { + my( $self, $pack ) = @_; $pack = $pack || $self->caller(1) || $self->exported_to; - return 0 unless $pack; + return unless $pack; - no strict 'refs'; ## no critic - return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'} - : 0; + no strict 'refs'; ## no critic + return ${ $pack . '::TODO' }; +} + +=item B + + my $in_todo = $Test->in_todo; + +Returns true if the test is currently inside a TODO block. + +=cut + +sub in_todo { + my $self = shift; + + local $Level = $Level + 1; + return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0; +} + +=item B + + $Test->todo_start(); + $Test->todo_start($message); + +This method allows you declare all subsequent tests as TODO tests, up until +the C method has been called. + +The C and C<$TODO> syntax is generally pretty good about figuring out +whether or not we're in a TODO test. However, often we find that this is not +possible to determine (such as when we want to use C<$TODO> but +the tests are being executed in other packages which can't be inferred +beforehand). + +Note that you can use this to nest "todo" tests + + $Test->todo_start('working on this'); + # lots of code + $Test->todo_start('working on that'); + # more code + $Test->todo_end; + $Test->todo_end; + +This is generally not recommended, but large testing systems often have weird +internal needs. + +We've tried to make this also work with the TODO: syntax, but it's not +guaranteed and its use is also discouraged: + + TODO: { + local $TODO = 'We have work to do!'; + $Test->todo_start('working on this'); + # lots of code + $Test->todo_start('working on that'); + # more code + $Test->todo_end; + $Test->todo_end; + } + +Pick one style or another of "TODO" to be on the safe side. + +=cut + +sub todo_start { + my $self = shift; + my $message = @_ ? shift : ''; + + $self->{Start_Todo}++; + if( $self->in_todo ) { + push @{ $self->{Todo_Stack} } => $self->todo; + } + $self->{Todo} = $message; + + return; +} + +=item C + + $Test->todo_end; + +Stops running tests as "TODO" tests. This method is fatal if called without a +preceding C method call. + +=cut + +sub todo_end { + my $self = shift; + + if( !$self->{Start_Todo} ) { + $self->croak('todo_end() called without todo_start()'); + } + + $self->{Start_Todo}--; + + if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) { + $self->{Todo} = pop @{ $self->{Todo_Stack} }; + } + else { + delete $self->{Todo}; + } + + return; } =item B @@ -1624,17 +1959,24 @@ sub todo { my($pack, $file, $line) = $Test->caller; my($pack, $file, $line) = $Test->caller($height); -Like the normal caller(), except it reports according to your level(). +Like the normal C, except it reports according to your C. + +C<$height> will be added to the C. -C<$height> will be added to the level(). +If C winds up off the top of the stack it report the highest context. =cut -sub caller { - my($self, $height) = @_; +sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms) + my( $self, $height ) = @_; $height ||= 0; - my @caller = CORE::caller($self->level + $height + 1); + my $level = $self->level + $height + 1; + my @caller; + do { + @caller = CORE::caller( $level ); + $level--; + } until @caller; return wantarray ? @caller : $caller[0]; } @@ -1660,52 +2002,53 @@ error message. sub _sanity_check { 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!'); - $self->_whoa($self->{Curr_Test} != @{ $self->{Test_Results} }, - 'Somehow you got a different number of results than tests ran!'); + $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' ); + $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} }, + 'Somehow you got a different number of results than tests ran!' ); + + return; } =item B<_whoa> $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 +A sanity check, similar to C. If the C<$check> is true, something +has gone horribly wrong. It will die with the given C<$description> and a note to contact the author. =cut sub _whoa { - my($self, $check, $desc) = @_; - if( $check ) { + my( $self, $check, $desc ) = @_; + if($check) { local $Level = $Level + 1; $self->croak(<<"WHOA"); WHOA! $desc This should never happen! Please contact the author immediately! WHOA } + + return; } =item B<_my_exit> _my_exit($exit_num); -Perl seems to have some trouble with exiting inside an END block. 5.005_03 -and 5.6.1 both seem to do odd things. Instead, this function edits $? -directly. It should ONLY be called from inside an END block. It +Perl seems to have some trouble with exiting inside an C block. 5.005_03 +and 5.6.1 both seem to do odd things. Instead, this function edits C<$?> +directly. It should B be called from inside an C block. It doesn't actually exit, that's your job. =cut sub _my_exit { - $? = $_[0]; + $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars) return 1; } - =back =end _private @@ -1716,15 +2059,19 @@ sub _ending { my $self = shift; my $real_exit_code = $?; - $self->_sanity_check(); # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. if( $self->{Original_Pid} != $$ ) { return; } - - # Exit if plan() was never called. This is so "require Test::Simple" + + # Ran tests but never declared a plan or hit done_testing + if( !$self->{Have_Plan} and $self->{Curr_Test} ) { + $self->diag("Tests were run but no plan was declared and done_testing() was not seen."); + } + + # Exit if plan() was never called. This is so "require Test::Simple" # doesn't puke. if( !$self->{Have_Plan} ) { return; @@ -1737,41 +2084,34 @@ sub _ending { # Figure out if we passed or failed and print helpful messages. my $test_results = $self->{Test_Results}; - if( @$test_results ) { + if(@$test_results) { # The plan? We have no plan. if( $self->{No_Plan} ) { - $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header; + $self->_output_plan($self->{Curr_Test}) 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..$self->{Expected_Tests}-1 ) { + 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..$self->{Curr_Test}-1]; + my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ]; my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; - if( $num_extra < 0 ) { - my $s = $self->{Expected_Tests} == 1 ? '' : 's'; - $self->diag(<<"FAIL"); -Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}. -FAIL - } - elsif( $num_extra > 0 ) { + if( $num_extra != 0 ) { my $s = $self->{Expected_Tests} == 1 ? '' : 's'; $self->diag(<<"FAIL"); -Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra. +Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}. FAIL } - if ( $num_failed ) { + if($num_failed) { my $num_tests = $self->{Curr_Test}; my $s = $num_failed == 1 ? '' : 's'; @@ -1782,16 +2122,16 @@ Looks like you failed $num_failed test$s of $num_tests$qualifier. FAIL } - if( $real_exit_code ) { + if($real_exit_code) { $self->diag(<<"FAIL"); -Looks like your test died just after $self->{Curr_Test}. +Looks like your test exited with $real_exit_code just after $self->{Curr_Test}. FAIL - _my_exit( 255 ) && return; + _my_exit($real_exit_code) && return; } my $exit_code; - if( $num_failed ) { + if($num_failed) { $exit_code = $num_failed <= 254 ? $num_failed : 254; } elsif( $num_extra != 0 ) { @@ -1801,21 +2141,23 @@ FAIL $exit_code = 0; } - _my_exit( $exit_code ) && return; + _my_exit($exit_code) && return; } - elsif ( $self->{Skip_All} ) { - _my_exit( 0 ) && return; + elsif( $self->{Skip_All} ) { + _my_exit(0) && return; } - elsif ( $real_exit_code ) { - $self->diag(<<'FAIL'); -Looks like your test died before it could output anything. + elsif($real_exit_code) { + $self->diag(<<"FAIL"); +Looks like your test exited with $real_exit_code before it could output anything. FAIL - _my_exit( 255 ) && return; + _my_exit($real_exit_code) && return; } else { $self->diag("No tests run!\n"); - _my_exit( 255 ) && return; + _my_exit(255) && return; } + + $self->_whoa( 1, "We fell off the end of _ending()" ); } END { @@ -1840,12 +2182,11 @@ So the exit codes are... If you fail more than 254 tests, it will be reported as 254. - =head1 THREADS 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. +the test number using C they will all be effected. While versions earlier than 5.8.1 had threads they contain too many bugs to support. @@ -1853,6 +2194,21 @@ bugs to support. Test::Builder is only thread-aware if threads.pm is loaded I Test::Builder. +=head1 MEMORY + +An informative hash, accessable via C<>, is stored for each +test you perform. So memory usage will scale linearly with each test +run. Although this is not a problem for most test suites, it can +become an issue if you do large (hundred thousands to million) +combinatorics tests in the same run. + +In such cases, you are advised to either split the test file into smaller +ones, or use a reverse approach, doing "normal" (code) compares and +triggering fail() should anything go unexpected. + +Future versions of Test::Builder will have a way to turn history off. + + =head1 EXAMPLES CPAN can provide the best examples. Test::Simple, Test::More, @@ -1869,10 +2225,10 @@ Eschwern@pobox.comE =head1 COPYRIGHT -Copyright 2002, 2004 by chromatic Echromatic@wgz.orgE and - Michael G Schwern Eschwern@pobox.comE. +Copyright 2002-2008 by chromatic Echromatic@wgz.orgE and + Michael G Schwern Eschwern@pobox.comE. -This program is free software; you can redistribute it and/or +This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F @@ -1880,3 +2236,4 @@ See F =cut 1; +