Update to 0.92; patch by Iain Arnell (BZ#519417) diff -urN perl-5.10.0.orig/lib/Test/Builder/Module.pm perl-5.10.0/lib/Test/Builder/Module.pm --- perl-5.10.0.orig/lib/Test/Builder/Module.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Builder/Module.pm 2009-08-26 06:14:11.000000000 +0200 @@ -1,24 +1,24 @@ package Test::Builder::Module; +use strict; + use Test::Builder; require Exporter; -@ISA = qw(Exporter); +our @ISA = qw(Exporter); -$VERSION = '0.72'; - -use strict; +our $VERSION = '0.92'; +$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) # 5.004's Exporter doesn't have export_to_level. my $_export_to_level = sub { - my $pkg = shift; - my $level = shift; - (undef) = shift; # redundant arg - my $callpkg = caller($level); - $pkg->export($callpkg, @_); + my $pkg = shift; + my $level = shift; + (undef) = shift; # redundant arg + my $callpkg = caller($level); + $pkg->export( $callpkg, @_ ); }; - =head1 NAME Test::Builder::Module - Base class for test modules @@ -84,33 +84,35 @@ sub import { my($class) = shift; + # Don't run all this when loading ourself. + return 1 if $class eq 'Test::Builder::Module'; + my $test = $class->builder; my $caller = caller; $test->exported_to($caller); - $class->import_extra(\@_); - my(@imports) = $class->_strip_imports(\@_); + $class->import_extra( \@_ ); + my(@imports) = $class->_strip_imports( \@_ ); $test->plan(@_); - $class->$_export_to_level(1, $class, @imports); + $class->$_export_to_level( 1, $class, @imports ); } - sub _strip_imports { my $class = shift; my $list = shift; my @imports = (); my @other = (); - my $idx = 0; + my $idx = 0; while( $idx <= $#{$list} ) { my $item = $list->[$idx]; if( defined $item and $item eq 'import' ) { - push @imports, @{$list->[$idx+1]}; + push @imports, @{ $list->[ $idx + 1 ] }; $idx++; } else { @@ -125,7 +127,6 @@ return @imports; } - =head3 import_extra Your::Module->import_extra(\@import_args); @@ -143,8 +144,7 @@ =cut -sub import_extra {} - +sub import_extra { } =head2 Builder @@ -178,5 +178,4 @@ return Test::Builder->new; } - 1; diff -urN perl-5.10.0.orig/lib/Test/Builder/Tester/Color.pm perl-5.10.0/lib/Test/Builder/Tester/Color.pm --- perl-5.10.0.orig/lib/Test/Builder/Tester/Color.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Builder/Tester/Color.pm 2009-08-26 06:14:11.000000000 +0200 @@ -1,9 +1,11 @@ package Test::Builder::Tester::Color; use strict; +our $VERSION = "1.18"; require Test::Builder::Tester; + =head1 NAME Test::Builder::Tester::Color - turn on colour in Test::Builder::Tester @@ -25,8 +27,7 @@ =cut -sub import -{ +sub import { Test::Builder::Tester::color(1); } diff -urN perl-5.10.0.orig/lib/Test/Builder/Tester.pm perl-5.10.0/lib/Test/Builder/Tester.pm --- perl-5.10.0.orig/lib/Test/Builder/Tester.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Builder/Tester.pm 2009-08-26 06:14:11.000000000 +0200 @@ -1,8 +1,7 @@ package Test::Builder::Tester; use strict; -use vars qw(@EXPORT $VERSION @ISA); -$VERSION = "1.09"; +our $VERSION = "1.18"; use Test::Builder; use Symbol; @@ -56,21 +55,20 @@ ### use Exporter; -@ISA = qw(Exporter); +our @ISA = qw(Exporter); -@EXPORT = qw(test_out test_err test_fail test_diag test_test line_num); +our @EXPORT = qw(test_out test_err test_fail test_diag test_test line_num); # _export_to_level and import stolen directly from Test::More. I am # the king of cargo cult programming ;-) # 5.004's Exporter doesn't have export_to_level. -sub _export_to_level -{ - my $pkg = shift; - my $level = shift; - (undef) = shift; # XXX redundant arg - my $callpkg = caller($level); - $pkg->export($callpkg, @_); +sub _export_to_level { + my $pkg = shift; + my $level = shift; + (undef) = shift; # XXX redundant arg + my $callpkg = caller($level); + $pkg->export( $callpkg, @_ ); } sub import { @@ -83,14 +81,14 @@ $t->plan(@plan); my @imports = (); - foreach my $idx (0..$#plan) { + foreach my $idx ( 0 .. $#plan ) { if( $plan[$idx] eq 'import' ) { - @imports = @{$plan[$idx+1]}; + @imports = @{ $plan[ $idx + 1 ] }; last; } } - __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); + __PACKAGE__->_export_to_level( 1, __PACKAGE__, @imports ); } ### @@ -124,8 +122,7 @@ my $original_harness_env; # function that starts testing and redirects the filehandles for now -sub _start_testing -{ +sub _start_testing { # even if we're running under Test::Harness pretend we're not # for now. This needed so Test::Builder doesn't add extra spaces $original_harness_env = $ENV{HARNESS_ACTIVE} || 0; @@ -146,7 +143,7 @@ $err->reset(); # remeber that we're testing - $testing = 1; + $testing = 1; $testing_num = $t->current_test; $t->current_test(0); @@ -188,20 +185,18 @@ =cut -sub test_out(@) -{ +sub test_out { # do we need to do any setup? _start_testing() unless $testing; - $out->expect(@_) + $out->expect(@_); } -sub test_err(@) -{ +sub test_err { # do we need to do any setup? _start_testing() unless $testing; - $err->expect(@_) + $err->expect(@_); } =item test_fail @@ -230,14 +225,13 @@ =cut -sub test_fail -{ +sub test_fail { # do we need to do any setup? _start_testing() unless $testing; # work out what line we should be on - my ($package, $filename, $line) = caller; - $line = $line + (shift() || 0); # prevent warnings + my( $package, $filename, $line ) = caller; + $line = $line + ( shift() || 0 ); # prevent warnings # expect that on stderr $err->expect("# Failed test ($0 at line $line)"); @@ -273,14 +267,13 @@ =cut -sub test_diag -{ +sub test_diag { # do we need to do any setup? _start_testing() unless $testing; # expect the same thing, but prepended with "# " local $_; - $err->expect(map {"# $_"} @_) + $err->expect( map { "# $_" } @_ ); } =item test_test @@ -322,24 +315,23 @@ =cut -sub test_test -{ - # decode the arguements as described in the pod - my $mess; - my %args; - if (@_ == 1) - { $mess = shift } - else - { - %args = @_; - $mess = $args{name} if exists($args{name}); - $mess = $args{title} if exists($args{title}); - $mess = $args{label} if exists($args{label}); - } +sub test_test { + # decode the arguements as described in the pod + my $mess; + my %args; + if( @_ == 1 ) { + $mess = shift + } + else { + %args = @_; + $mess = $args{name} if exists( $args{name} ); + $mess = $args{title} if exists( $args{title} ); + $mess = $args{label} if exists( $args{label} ); + } # er, are we testing? croak "Not testing. You must declare output with a test function first." - unless $testing; + unless $testing; # okay, reconnect the test suite back to the saved handles $t->output($original_output_handle); @@ -354,20 +346,20 @@ $ENV{HARNESS_ACTIVE} = $original_harness_env; # check the output we've stashed - unless ($t->ok( ($args{skip_out} || $out->check) - && ($args{skip_err} || $err->check), - $mess)) + unless( $t->ok( ( $args{skip_out} || $out->check ) && + ( $args{skip_err} || $err->check ), $mess ) + ) { - # print out the diagnostic information about why this - # test failed + # print out the diagnostic information about why this + # test failed - local $_; + local $_; - $t->diag(map {"$_\n"} $out->complaint) - unless $args{skip_out} || $out->check; + $t->diag( map { "$_\n" } $out->complaint ) + unless $args{skip_out} || $out->check; - $t->diag(map {"$_\n"} $err->complaint) - unless $args{skip_err} || $err->check; + $t->diag( map { "$_\n" } $err->complaint ) + unless $args{skip_err} || $err->check; } } @@ -383,10 +375,9 @@ =cut -sub line_num -{ - my ($package, $filename, $line) = caller; - return $line + (shift() || 0); # prevent warnings +sub line_num { + my( $package, $filename, $line ) = caller; + return $line + ( shift() || 0 ); # prevent warnings } =back @@ -432,10 +423,10 @@ =cut my $color; -sub color -{ - $color = shift if @_; - $color; + +sub color { + $color = shift if @_; + $color; } =back @@ -490,21 +481,18 @@ ## # add line(s) to be expected -sub expect -{ +sub expect { my $self = shift; my @checks = @_; foreach my $check (@checks) { $check = $self->_translate_Failed_check($check); - push @{$self->{wanted}}, ref $check ? $check : "$check\n"; + push @{ $self->{wanted} }, ref $check ? $check : "$check\n"; } } - -sub _translate_Failed_check -{ - my($self, $check) = @_; +sub _translate_Failed_check { + my( $self, $check ) = @_; if( $check =~ /\A(.*)# (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) { $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/"; @@ -513,21 +501,19 @@ return $check; } - ## # return true iff the expected data matches the got data -sub check -{ +sub check { my $self = shift; # turn off warnings as these might be undef local $^W = 0; - my @checks = @{$self->{wanted}}; - my $got = $self->{got}; + my @checks = @{ $self->{wanted} }; + my $got = $self->{got}; foreach my $check (@checks) { - $check = "\Q$check\E" unless ($check =~ s,^/(.*)/$,$1, or ref $check); + $check = "\Q$check\E" unless( $check =~ s,^/(.*)/$,$1, or ref $check ); return 0 unless $got =~ s/^$check//; } @@ -538,82 +524,71 @@ # a complaint message about the inputs not matching (to be # used for debugging messages) -sub complaint -{ - my $self = shift; +sub complaint { + my $self = shift; my $type = $self->type; my $got = $self->got; - my $wanted = join "\n", @{$self->wanted}; + my $wanted = join "\n", @{ $self->wanted }; # are we running in colour mode? - if (Test::Builder::Tester::color) - { - # get color - eval "require Term::ANSIColor"; - unless ($@) - { - # colours - - my $green = Term::ANSIColor::color("black"). - Term::ANSIColor::color("on_green"); - my $red = Term::ANSIColor::color("black"). - Term::ANSIColor::color("on_red"); - my $reset = Term::ANSIColor::color("reset"); - - # work out where the two strings start to differ - my $char = 0; - $char++ while substr($got, $char, 1) eq substr($wanted, $char, 1); - - # get the start string and the two end strings - my $start = $green . substr($wanted, 0, $char); - my $gotend = $red . substr($got , $char) . $reset; - my $wantedend = $red . substr($wanted, $char) . $reset; - - # make the start turn green on and off - $start =~ s/\n/$reset\n$green/g; - - # make the ends turn red on and off - $gotend =~ s/\n/$reset\n$red/g; - $wantedend =~ s/\n/$reset\n$red/g; - - # rebuild the strings - $got = $start . $gotend; - $wanted = $start . $wantedend; - } + if(Test::Builder::Tester::color) { + # get color + eval { require Term::ANSIColor }; + unless($@) { + # colours + + my $green = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_green"); + my $red = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_red"); + my $reset = Term::ANSIColor::color("reset"); + + # work out where the two strings start to differ + my $char = 0; + $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 ); + + # get the start string and the two end strings + my $start = $green . substr( $wanted, 0, $char ); + my $gotend = $red . substr( $got, $char ) . $reset; + my $wantedend = $red . substr( $wanted, $char ) . $reset; + + # make the start turn green on and off + $start =~ s/\n/$reset\n$green/g; + + # make the ends turn red on and off + $gotend =~ s/\n/$reset\n$red/g; + $wantedend =~ s/\n/$reset\n$red/g; + + # rebuild the strings + $got = $start . $gotend; + $wanted = $start . $wantedend; + } } - return "$type is:\n" . - "$got\nnot:\n$wanted\nas expected" + return "$type is:\n" . "$got\nnot:\n$wanted\nas expected"; } ## # forget all expected and got data -sub reset -{ +sub reset { my $self = shift; %$self = ( - type => $self->{type}, - got => '', - wanted => [], - ); + type => $self->{type}, + got => '', + wanted => [], + ); } - -sub got -{ +sub got { my $self = shift; return $self->{got}; } -sub wanted -{ +sub wanted { my $self = shift; return $self->{wanted}; } -sub type -{ +sub type { my $self = shift; return $self->{type}; } @@ -622,26 +597,24 @@ # tie interface ### -sub PRINT { +sub PRINT { my $self = shift; $self->{got} .= join '', @_; } sub TIEHANDLE { - my($class, $type) = @_; + my( $class, $type ) = @_; - my $self = bless { - type => $type - }, $class; + my $self = bless { type => $type }, $class; $self->reset; return $self; } -sub READ {} -sub READLINE {} -sub GETC {} -sub FILENO {} +sub READ { } +sub READLINE { } +sub GETC { } +sub FILENO { } 1; diff -urN perl-5.10.0.orig/lib/Test/Builder.pm perl-5.10.0/lib/Test/Builder.pm --- perl-5.10.0.orig/lib/Test/Builder.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Builder.pm 2009-08-26 06:14:11.000000000 +0200 @@ -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.72'; -$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 @@ 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 @@ } } - =head1 NAME Test::Builder - Backend for building test libraries @@ -73,28 +75,15 @@ =head1 SYNOPSIS package My::Test::Module; - use Test::Builder; - require Exporter; - @ISA = qw(Exporter); - @EXPORT = qw(ok); + use base 'Test::Builder::Module'; - my $Test = Test::Builder->new; - $Test->output('my_logfile'); - - sub import { - my($self) = shift; - my $pack = caller; - - $Test->exported_to($pack); - $Test->plan(@_); - - $self->export_to_level(1, $self, 'ok'); - } + my $CLASS = __PACKAGE__; sub ok { my($test, $name) = @_; + my $tb = $CLASS->builder; - $Test->ok($test, $name); + $tb->ok($test, $name); } @@ -117,7 +106,7 @@ 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. @@ -128,13 +117,13 @@ =cut my $Test = Test::Builder->new; + sub new { my($class) = shift; $Test ||= $class->create; return $Test; } - =item B my $Test = Test::Builder->create; @@ -168,37 +157,43 @@ =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. $Level = 1; - $self->{Test_Died} = 0; $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_Stack} = []; + $self->{Start_Todo} = 0; + $self->{Opened_Testhandles} = 0; - $self->_dup_stdhandles unless $^C; + $self->_dup_stdhandles; - return undef; + return; } =back @@ -210,25 +205,6 @@ =over 4 -=item B - - my $pack = $Test->exported_to; - $Test->exported_to($pack); - -Tells Test::Builder what package you exported your functions to. -This is important for getting TODO tests right. - -=cut - -sub exported_to { - my($self, $pack) = @_; - - if( defined $pack ) { - $self->{Exported_To} = $pack; - } - return $self->{Exported_To}; -} - =item B $Test->plan('no_plan'); @@ -238,53 +214,62 @@ 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 @@ -293,73 +278,204 @@ 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; + $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 @@ -368,7 +484,7 @@ They all return true if the test passed, false if the test failed. -$name is always optional. +C<$name> is always optional. =over 4 @@ -376,42 +492,43 @@ $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($pack, $file, $line) = $self->caller; + # Capture the value of $TODO for the rest of this ok() call + # so it can more easily be found by other routines. + my $todo = $self->todo(); + my $in_todo = $self->in_todo; + local $self->{Todo} = $todo if $in_todo; - my $todo = $self->todo($pack); - $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 ); @@ -421,16 +538,16 @@ $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'; } @@ -439,309 +556,341 @@ $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}; - - 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]); - } - } + 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; + if( defined $name ) { + $self->diag(qq[ $msg test '$name'\n]); + $self->diag(qq[ at $file line $line.\n]); + } + else { + $self->diag(qq[ $msg test at $file line $line.\n]); + } + } return $test ? 1 : 0; } - sub _unoverload { - my $self = shift; - my $type = shift; + 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; - 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'; - 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 @@ =cut sub BAIL_OUT { - my($self, $reason) = @_; + my( $self, $reason ) = @_; $self->{Bailed_Out} = 1; $self->_print("Bail out! $reason"); @@ -785,52 +934,50 @@ *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->_plan_check; + $self->_unoverload_str( \$why ); - 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 @@ =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 @@ $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 @@ 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,48 +1061,60 @@ =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( 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; } 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 directive. + # Yes, it has to look like this or 5.4.5 won't see the #line + # directive. # Don't ask me, man, I just work here. $test = eval " $code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0}; @@ -967,10 +1125,12 @@ $ok = $self->ok( $test, $name ); } - unless( $ok ) { + unless($ok) { $this = defined $this ? "'$this'" : 'undef'; my $match = $cmp eq '=~' ? "doesn't match" : "matches"; - $self->diag(sprintf <diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex ); %s %13s '%s' DIAGNOSTIC @@ -980,7 +1140,6 @@ return $ok; } - # I'm not ready to publish this. It doesn't deal with array return # values from the code or context. @@ -991,23 +1150,33 @@ 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 @@ -1017,24 +1186,23 @@ 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 @@ -1047,7 +1215,7 @@ $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. @@ -1067,7 +1235,7 @@ =cut sub level { - my($self, $level) = @_; + my( $self, $level ) = @_; if( defined $level ) { $Level = $level; @@ -1075,7 +1243,6 @@ return $Level; } - =item B $Test->use_numbers($on_or_off); @@ -1100,7 +1267,7 @@ =cut sub use_numbers { - my($self, $use_nums) = @_; + my( $self, $use_nums ) = @_; if( defined $use_nums ) { $self->{Use_Nums} = $use_nums; @@ -1108,13 +1275,12 @@ 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 @@ -1137,7 +1303,7 @@ my $method = lc $attribute; my $code = sub { - my($self, $no) = @_; + my( $self, $no ) = @_; if( defined $no ) { $self->{$attribute} = $no; @@ -1145,11 +1311,10 @@ return $self->{$attribute}; }; - no strict 'refs'; - *{__PACKAGE__.'::'.$method} = $code; + no strict 'refs'; ## no critic + *{ __PACKAGE__ . '::' . $method } = $code; } - =back =head2 Output @@ -1165,11 +1330,11 @@ $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 @@ -1177,7 +1342,7 @@ 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(...); @@ -1188,7 +1353,35 @@ =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; @@ -1200,32 +1393,66 @@ # 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 @@ -1233,70 +1460,53 @@ 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 - -sub _print_diag { - my $self = shift; - - local($\, $", $,) = (undef, ' ', ''); - my $fh = $self->todo ? $self->todo_output : $self->failure_output; - print $fh @_; -} - =item B - $Test->output($fh); - $Test->output($file); +=item B -Where normal "ok/not ok" test output should go. +=item B -Defaults to STDOUT. + my $filehandle = $Test->output; + $Test->output($filehandle); + $Test->output($filename); + $Test->output(\$scalar); + +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>. -=item B +B is where normal "ok/not ok" test output goes. - $Test->failure_output($fh); - $Test->failure_output($file); +Defaults to STDOUT. -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); @@ -1305,7 +1515,7 @@ } sub failure_output { - my($self, $fh) = @_; + my( $self, $fh ) = @_; if( defined $fh ) { $self->{Fail_FH} = $self->_new_fh($fh); @@ -1314,7 +1524,7 @@ } sub todo_output { - my($self, $fh) = @_; + my( $self, $fh ) = @_; if( defined $fh ) { $self->{Todo_FH} = $self->_new_fh($fh); @@ -1322,7 +1532,6 @@ return $self->{Todo_FH}; } - sub _new_fh { my $self = shift; my($file_or_fh) = shift; @@ -1331,24 +1540,37 @@ 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 { - $fh = do { local *FH }; - open $fh, ">$file_or_fh" or - $self->croak("Can't open test output log $file_or_fh: $!"); - _autoflush($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 ); sub _dup_stdhandles { my $self = shift; @@ -1357,41 +1579,80 @@ # 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(\*TESTERR); - _autoflush(\*STDERR); + _autoflush($Testout); + _autoflush( \*STDOUT ); + _autoflush($Testerr); + _autoflush( \*STDERR ); - $self->output(\*TESTOUT); - $self->failure_output(\*TESTERR); - $self->todo_output(\*TESTOUT); -} + $self->reset_outputs; + return; +} -my $Opened_Testhandles = 0; sub _open_testhandles { - return if $Opened_Testhandles; + my $self = shift; + + 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: $!"; - $Opened_Testhandles = 1; + 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 ); + + $self->{Opened_Testhandles} = 1; + + return; +} + +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; + } + ); + + 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 $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 @@ -1399,28 +1660,20 @@ 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 @@ -1444,28 +1697,26 @@ =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. @@ -1476,7 +1727,6 @@ return $self->{Curr_Test}; } - =item B my @tests = $Test->summary; @@ -1498,7 +1748,7 @@ 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? @@ -1512,7 +1762,7 @@ '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. @@ -1525,16 +1775,16 @@ 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', @@ -1553,30 +1803,154 @@ 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. - -todo() is about finding the right package to look for $TODO in. It -uses the exported_to() package to find it. If that's not set, it's -pretty good at guessing the right package to look at based on $Level. +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. + +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}; - $pack = $pack || $self->exported_to || $self->caller($Level); - return 0 unless $pack; + local $Level = $Level + 1; + my $todo = $self->find_TODO($pack); + return $todo if defined $todo; - no strict 'refs'; - return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'} - : 0; + 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 unless $pack; + + 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 @@ -1585,15 +1959,24 @@ 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. + +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]; } @@ -1619,126 +2002,116 @@ 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 =cut -$SIG{__DIE__} = sub { - # We don't want to muck with death in an eval, but $^S isn't - # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing - # with it. Instead, we use caller. This also means it runs under - # 5.004! - my $in_eval = 0; - for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) { - $in_eval = 1 if $sub =~ /^\(eval\)/; - } - $Test->{Test_Died} = 1 unless $in_eval; -}; - sub _ending { my $self = shift; - $self->_sanity_check(); + my $real_exit_code = $?; # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. - # Exit if plan() was never called. This is so "require Test::Simple" + if( $self->{Original_Pid} != $$ ) { + return; + } + + # 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; + } + # Don't do an ending if we bailed out. - if( ($self->{Original_Pid} != $$) or - (!$self->{Have_Plan} && !$self->{Test_Died}) or - $self->{Bailed_Out} - ) - { - _my_exit($?); - return; + if( $self->{Bailed_Out} ) { + return; } # Figure out if we passed or failed and print helpful messages. 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'; @@ -1749,16 +2122,16 @@ FAIL } - if( $self->{Test_Died} ) { + 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 ) { @@ -1768,21 +2141,23 @@ $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 ( $self->{Test_Died} ) { - $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 { @@ -1807,12 +2182,11 @@ 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. @@ -1820,6 +2194,21 @@ 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, @@ -1836,10 +2225,10 @@ =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 @@ -1847,3 +2236,4 @@ =cut 1; + diff -urN perl-5.10.0.orig/lib/Test/More.pm perl-5.10.0/lib/Test/More.pm --- perl-5.10.0.orig/lib/Test/More.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/More.pm 2009-08-26 06:14:11.000000000 +0200 @@ -1,39 +1,40 @@ package Test::More; -use 5.004; - +use 5.006; use strict; +use warnings; + +#---- perlcritic exemptions. ----# +# We use a lot of subroutine prototypes +## no critic (Subroutines::ProhibitSubroutinePrototypes) # Can't use Carp because it might cause use_ok() to accidentally succeed # even though the module being used forgot to use Carp. Yes, this # actually happened. sub _carp { - my($file, $line) = (caller(1))[1,2]; - warn @_, " at $file line $line\n"; + my( $file, $line ) = ( caller(1) )[ 1, 2 ]; + return warn @_, " at $file line $line\n"; } - - -use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); -$VERSION = '0.72'; -$VERSION = eval $VERSION; # make the alpha version come out as a number +our $VERSION = '0.92'; +$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) use Test::Builder::Module; -@ISA = qw(Test::Builder::Module); -@EXPORT = qw(ok use_ok require_ok - is isnt like unlike is_deeply - cmp_ok - skip todo todo_skip - pass fail - eq_array eq_hash eq_set - $TODO - plan - can_ok isa_ok - diag - BAIL_OUT - ); - +our @ISA = qw(Test::Builder::Module); +our @EXPORT = qw(ok use_ok require_ok + is isnt like unlike is_deeply + cmp_ok + skip todo todo_skip + pass fail + eq_array eq_hash eq_set + $TODO + plan + done_testing + can_ok isa_ok new_ok + diag note explain + BAIL_OUT +); =head1 NAME @@ -43,9 +44,9 @@ use Test::More tests => 23; # or - use Test::More qw(no_plan); - # or use Test::More skip_all => $reason; + # or + use Test::More; # see done_testing() BEGIN { use_ok( 'Some::Module' ); } require_ok( 'Some::Module' ); @@ -95,7 +96,7 @@ =head1 DESCRIPTION B If you're just getting started writing tests, have a look at -Test::Simple first. This is a drop in replacement for Test::Simple +L first. This is a drop in replacement for Test::Simple which you can switch to once you get the hang of basic testing. The purpose of this module is to provide a wide range of testing @@ -115,14 +116,19 @@ use Test::More tests => 23; -There are rare cases when you will not know beforehand how many tests -your script is going to run. In this case, you can declare that you -have no plan. (Try to avoid using this as it weakens your test.) +There are cases when you will not know beforehand how many tests your +script is going to run. In this case, you can declare your tests at +the end. + + use Test::More; + + ... run your tests ... - use Test::More qw(no_plan); + done_testing( $number_of_tests_run ); -B: using no_plan requires a Test::Harness upgrade else it will -think everything has failed. See L). +Sometimes you really don't know how many tests were run, or it's too +difficult to calculate. In which case you can leave off +$number_of_tests_run. In some cases, you'll want to completely skip an entire testing script. @@ -159,10 +165,9 @@ sub plan { my $tb = Test::More->builder; - $tb->plan(@_); + return $tb->plan(@_); } - # This implements "use Test::More 'no_diag'" but the behavior is # deprecated. sub import_extra { @@ -170,7 +175,7 @@ my $list = shift; my @other = (); - my $idx = 0; + my $idx = 0; while( $idx <= $#{$list} ) { my $item = $list->[$idx]; @@ -185,8 +190,35 @@ } @$list = @other; + + return; } +=over 4 + +=item B + + done_testing(); + done_testing($number_of_tests); + +If you don't know how many tests you're going to run, you can issue +the plan when you're done running tests. + +$number_of_tests is the same as plan(), it's the number of tests you +expected to run. You can omit this, in which case the number of tests +you ran doesn't matter, just the fact that your tests ran to +conclusion. + +This is safer than and replaces the "no_plan" plan. + +=back + +=cut + +sub done_testing { + my $tb = Test::More->builder; + $tb->done_testing(@_); +} =head2 Test names @@ -257,10 +289,10 @@ =cut sub ok ($;$) { - my($test, $name) = @_; + my( $test, $name ) = @_; my $tb = Test::More->builder; - $tb->ok($test, $name); + return $tb->ok( $test, $name ); } =item B @@ -318,6 +350,17 @@ ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' ); +A simple call to isnt() usually does not provide a strong test but there +are cases when you cannot say much more about a value than that it is +different from some other value: + + new_ok $obj, "Foo"; + + my $clone = $obj->clone; + isa_ok $obj, "Foo", "Foo->clone"; + + isnt $obj, $clone, "clone() produces a different object"; + For those grammatical pedants out there, there's an C function which is an alias of isnt(). @@ -326,18 +369,17 @@ sub is ($$;$) { my $tb = Test::More->builder; - $tb->is_eq(@_); + return $tb->is_eq(@_); } sub isnt ($$;$) { my $tb = Test::More->builder; - $tb->isnt_eq(@_); + return $tb->isnt_eq(@_); } *isn't = \&isnt; - =item B like( $got, qr/expected/, $test_name ); @@ -371,10 +413,9 @@ sub like ($$;$) { my $tb = Test::More->builder; - $tb->like(@_); + return $tb->like(@_); } - =item B unlike( $got, qr/expected/, $test_name ); @@ -387,10 +428,9 @@ sub unlike ($$;$) { my $tb = Test::More->builder; - $tb->unlike(@_); + return $tb->unlike(@_); } - =item B cmp_ok( $got, $op, $expected, $test_name ); @@ -422,15 +462,20 @@ cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); +It's especially useful when comparing greater-than or smaller-than +relation between values: + + cmp_ok( $some_value, '<=', $upper_limit ); + + =cut sub cmp_ok($$$;$) { my $tb = Test::More->builder; - $tb->cmp_ok(@_); + return $tb->cmp_ok(@_); } - =item B can_ok($module, @methods); @@ -461,17 +506,17 @@ =cut sub can_ok ($@) { - my($proto, @methods) = @_; + my( $proto, @methods ) = @_; my $class = ref $proto || $proto; my $tb = Test::More->builder; - unless( $class ) { + unless($class) { my $ok = $tb->ok( 0, "->can(...)" ); $tb->diag(' can_ok() called with empty class or reference'); return $ok; } - unless( @methods ) { + unless(@methods) { my $ok = $tb->ok( 0, "$class->can(...)" ); $tb->diag(' can_ok() called with no methods'); return $ok; @@ -479,24 +524,24 @@ my @nok = (); foreach my $method (@methods) { - $tb->_try(sub { $proto->can($method) }) or push @nok, $method; + $tb->_try( sub { $proto->can($method) } ) or push @nok, $method; } - my $name; - $name = @methods == 1 ? "$class->can('$methods[0]')" - : "$class->can(...)"; + my $name = (@methods == 1) ? "$class->can('$methods[0]')" : + "$class->can(...)" ; my $ok = $tb->ok( !@nok, $name ); - $tb->diag(map " $class->can('$_') failed\n", @nok); + $tb->diag( map " $class->can('$_') failed\n", @nok ); return $ok; } =item B - isa_ok($object, $class, $object_name); - isa_ok($ref, $type, $ref_name); + isa_ok($object, $class, $object_name); + isa_ok($subclass, $class, $object_name); + isa_ok($ref, $type, $ref_name); Checks to see if the given C<< $object->isa($class) >>. Also checks to make sure the object was defined in the first place. Handy for this sort @@ -512,6 +557,10 @@ to safeguard against your test script blowing up. +You can also test a class, to make sure that it has the right ancestor: + + isa_ok( 'Vole', 'Rodent' ); + It works on references, too: isa_ok( $array_ref, 'ARRAY' ); @@ -523,46 +572,52 @@ =cut sub isa_ok ($$;$) { - my($object, $class, $obj_name) = @_; + my( $object, $class, $obj_name ) = @_; my $tb = Test::More->builder; my $diag; - $obj_name = 'The object' unless defined $obj_name; - my $name = "$obj_name isa $class"; + if( !defined $object ) { + $obj_name = 'The thing' unless defined $obj_name; $diag = "$obj_name isn't defined"; } - elsif( !ref $object ) { - $diag = "$obj_name isn't a reference"; - } else { + my $whatami = ref $object ? 'object' : 'class'; # We can't use UNIVERSAL::isa because we want to honor isa() overrides - my($rslt, $error) = $tb->_try(sub { $object->isa($class) }); - if( $error ) { + my( $rslt, $error ) = $tb->_try( sub { $object->isa($class) } ); + if($error) { if( $error =~ /^Can't call method "isa" on unblessed reference/ ) { # Its an unblessed reference - if( !UNIVERSAL::isa($object, $class) ) { + $obj_name = 'The reference' unless defined $obj_name; + if( !UNIVERSAL::isa( $object, $class ) ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } - } else { + } + elsif( $error =~ /Can't call method "isa" without a package/ ) { + # It's something that can't even be a class + $diag = "$obj_name isn't a class or reference"; + } + else { die <isa on your object and got some weird error. +WHOA! I tried to call ->isa on your $whatami and got some weird error. Here's the error. $error WHOA } } - elsif( !$rslt ) { - my $ref = ref $object; - $diag = "$obj_name isn't a '$class' it's a '$ref'"; + else { + $obj_name = "The $whatami" unless defined $obj_name; + if( !$rslt ) { + my $ref = ref $object; + $diag = "$obj_name isn't a '$class' it's a '$ref'"; + } } } - - + my $name = "$obj_name isa $class"; my $ok; - if( $diag ) { + if($diag) { $ok = $tb->ok( 0, $name ); $tb->diag(" $diag\n"); } @@ -573,6 +628,49 @@ return $ok; } +=item B + + my $obj = new_ok( $class ); + my $obj = new_ok( $class => \@args ); + my $obj = new_ok( $class => \@args, $object_name ); + +A convenience function which combines creating an object and calling +isa_ok() on that object. + +It is basically equivalent to: + + my $obj = $class->new(@args); + isa_ok $obj, $class, $object_name; + +If @args is not given, an empty list will be used. + +This function only works on new() and it assumes new() will return +just a single object which isa C<$class>. + +=cut + +sub new_ok { + my $tb = Test::More->builder; + $tb->croak("new_ok() must be given at least a class") unless @_; + + my( $class, $args, $object_name ) = @_; + + $args ||= []; + $object_name = "The object" unless defined $object_name; + + my $obj; + my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } ); + if($success) { + local $Test::Builder::Level = $Test::Builder::Level + 1; + isa_ok $obj, $class, $object_name; + } + else { + $tb->ok( 0, "new() died" ); + $tb->diag(" Error was: $error"); + } + + return $obj; +} =item B @@ -593,12 +691,14 @@ sub pass (;$) { my $tb = Test::More->builder; - $tb->ok(1, @_); + + return $tb->ok( 1, @_ ); } sub fail (;$) { my $tb = Test::More->builder; - $tb->ok(0, @_); + + return $tb->ok( 0, @_ ); } =back @@ -653,38 +753,40 @@ =cut sub use_ok ($;@) { - my($module, @imports) = @_; + my( $module, @imports ) = @_; @imports = () unless @imports; my $tb = Test::More->builder; - my($pack,$filename,$line) = caller; - - local($@,$!,$SIG{__DIE__}); # isolate eval + my( $pack, $filename, $line ) = caller; + my $code; if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { # probably a version check. Perl needs to see the bare number # for it to work with non-Exporter based modules. - eval <ok( !$@, "use $module;" ); + my( $eval_result, $eval_error ) = _eval( $code, \@imports ); + my $ok = $tb->ok( $eval_result, "use $module;" ); - unless( $ok ) { - chomp $@; + unless($ok) { + chomp $eval_error; $@ =~ s{^BEGIN failed--compilation aborted at .*$} {BEGIN failed--compilation aborted at $filename line $line.}m; $tb->diag(< require_ok($module); @@ -711,20 +831,20 @@ # Module names must be barewords, files not. $module = qq['$module'] unless _is_module_name($module); - local($!, $@, $SIG{__DIE__}); # isolate eval - local $SIG{__DIE__}; - eval <ok( !$@, "require $module;" ); + my( $eval_result, $eval_error ) = _eval($code); + my $ok = $tb->ok( $eval_result, "require $module;" ); - unless( $ok ) { - chomp $@; + unless($ok) { + chomp $eval_error; $tb->diag(< and L provide more in-depth functionality along these lines. =cut -use vars qw(@Data_Stack %Refs_Seen); +our( @Data_Stack, %Refs_Seen ); my $DNE = bless [], 'Does::Not::Exist'; sub _dne { - ref $_[0] eq ref $DNE; + return ref $_[0] eq ref $DNE; } - +## no critic (Subroutines::RequireArgUnpacking) sub is_deeply { my $tb = Test::More->builder; unless( @_ == 2 or @_ == 3 ) { - my $msg = <ok(0); + return $tb->ok(0); } - my($got, $expected, $name) = @_; + my( $got, $expected, $name ) = @_; - $tb->_unoverload_str(\$expected, \$got); + $tb->_unoverload_str( \$expected, \$got ); my $ok; - if( !ref $got and !ref $expected ) { # neither is a reference - $ok = $tb->is_eq($got, $expected, $name); + if( !ref $got and !ref $expected ) { # neither is a reference + $ok = $tb->is_eq( $got, $expected, $name ); } - elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't - $ok = $tb->ok(0, $name); - $tb->diag( _format_stack({ vals => [ $got, $expected ] }) ); + elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't + $ok = $tb->ok( 0, $name ); + $tb->diag( _format_stack({ vals => [ $got, $expected ] }) ); } - else { # both references + else { # both references local @Data_Stack = (); - if( _deep_check($got, $expected) ) { - $ok = $tb->ok(1, $name); + if( _deep_check( $got, $expected ) ) { + $ok = $tb->ok( 1, $name ); } else { - $ok = $tb->ok(0, $name); - $tb->diag(_format_stack(@Data_Stack)); + $ok = $tb->ok( 0, $name ); + $tb->diag( _format_stack(@Data_Stack) ); } } @@ -831,11 +951,11 @@ sub _format_stack { my(@Stack) = @_; - my $var = '$FOO'; + my $var = '$FOO'; my $did_arrow = 0; foreach my $entry (@Stack) { my $type = $entry->{type} || ''; - my $idx = $entry->{'idx'}; + my $idx = $entry->{'idx'}; if( $type eq 'HASH' ) { $var .= "->" unless $did_arrow++; $var .= "{$idx}"; @@ -849,18 +969,19 @@ } } - my @vals = @{$Stack[-1]{vals}}[0,1]; + my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ]; my @vars = (); - ($vars[0] = $var) =~ s/\$FOO/ \$got/; - ($vars[1] = $var) =~ s/\$FOO/\$expected/; + ( $vars[0] = $var ) =~ s/\$FOO/ \$got/; + ( $vars[1] = $var ) =~ s/\$FOO/\$expected/; my $out = "Structures begin differing at:\n"; - foreach my $idx (0..$#vals) { + foreach my $idx ( 0 .. $#vals ) { my $val = $vals[$idx]; - $vals[$idx] = !defined $val ? 'undef' : - _dne($val) ? "Does not exist" : - ref $val ? "$val" : - "'$val'"; + $vals[$idx] + = !defined $val ? 'undef' + : _dne($val) ? "Does not exist" + : ref $val ? "$val" + : "'$val'"; } $out .= "$vars[0] = $vals[0]\n"; @@ -870,14 +991,13 @@ return $out; } - sub _type { my $thing = shift; return '' if !ref $thing; for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) { - return $type if UNIVERSAL::isa($thing, $type); + return $type if UNIVERSAL::isa( $thing, $type ); } return ''; @@ -903,6 +1023,8 @@ test output. Like C @diagnostic_message is simply concatenated together. +Returns false, so as to preserve failure. + Handy for this sort of thing: ok( grep(/foo/, @users), "There's a foo user" ) or @@ -922,14 +1044,49 @@ changing, but it is guaranteed that whatever you throw at it it won't interfere with the test. +=item B + + note(@diagnostic_message); + +Like diag(), except the message will not be seen when the test is run +in a harness. It will only be visible in the verbose TAP stream. + +Handy for putting in notes which might be useful for debugging, but +don't indicate a problem. + + note("Tempfile is $tempfile"); + =cut sub diag { - my $tb = Test::More->builder; + return Test::More->builder->diag(@_); +} - $tb->diag(@_); +sub note { + return Test::More->builder->note(@_); } +=item B + + my @dump = explain @diagnostic_message; + +Will dump the contents of any references in a human readable format. +Usually you want to pass this into C or C. + +Handy for things like... + + is_deeply($have, $want) || diag explain $have; + +or + + note explain \%args; + Some::Class->method(%args); + +=cut + +sub explain { + return Test::More->builder->explain(@_); +} =back @@ -993,9 +1150,9 @@ =cut -#'# +## no critic (Subroutines::RequireFinalReturn) sub skip { - my($why, $how_many) = @_; + my( $why, $how_many ) = @_; my $tb = Test::More->builder; unless( defined $how_many ) { @@ -1006,19 +1163,19 @@ } if( defined $how_many and $how_many =~ /\D/ ) { - _carp "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?"; + _carp + "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?"; $how_many = 1; } - for( 1..$how_many ) { + for( 1 .. $how_many ) { $tb->skip($why); } - local $^W = 0; + no warnings 'exiting'; last SKIP; } - =item B TODO: { @@ -1081,7 +1238,7 @@ =cut sub todo_skip { - my($why, $how_many) = @_; + my( $why, $how_many ) = @_; my $tb = Test::More->builder; unless( defined $how_many ) { @@ -1091,11 +1248,11 @@ $how_many = 1; } - for( 1..$how_many ) { + for( 1 .. $how_many ) { $tb->todo_skip($why); } - local $^W = 0; + no warnings 'exiting'; last TODO; } @@ -1131,11 +1288,13 @@ The test will exit with 255. +For even better control look at L. + =cut sub BAIL_OUT { my $reason = shift; - my $tb = Test::More->builder; + my $tb = Test::More->builder; $tb->BAIL_OUT($reason); } @@ -1174,14 +1333,14 @@ #'# sub eq_array { - local @Data_Stack; + local @Data_Stack = (); _deep_check(@_); } -sub _eq_array { - my($a1, $a2) = @_; +sub _eq_array { + my( $a1, $a2 ) = @_; - if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) { + if( grep _type($_) ne 'ARRAY', $a1, $a2 ) { warn "eq_array passed a non-array ref"; return 0; } @@ -1190,12 +1349,12 @@ my $ok = 1; my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; - for (0..$max) { + for( 0 .. $max ) { my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; - push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] }; - $ok = _deep_check($e1,$e2); + push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] }; + $ok = _deep_check( $e1, $e2 ); pop @Data_Stack if $ok; last unless $ok; @@ -1205,7 +1364,7 @@ } sub _deep_check { - my($e1, $e2) = @_; + my( $e1, $e2 ) = @_; my $tb = Test::More->builder; my $ok = 0; @@ -1217,27 +1376,31 @@ { # Quiet uninitialized value warnings when comparing undefs. - local $^W = 0; + no warnings 'uninitialized'; - $tb->_unoverload_str(\$e1, \$e2); + $tb->_unoverload_str( \$e1, \$e2 ); # Either they're both references or both not. - my $same_ref = !(!ref $e1 xor !ref $e2); - my $not_ref = (!ref $e1 and !ref $e2); + my $same_ref = !( !ref $e1 xor !ref $e2 ); + my $not_ref = ( !ref $e1 and !ref $e2 ); if( defined $e1 xor defined $e2 ) { $ok = 0; } - elsif ( _dne($e1) xor _dne($e2) ) { + elsif( !defined $e1 and !defined $e2 ) { + # Shortcut if they're both defined. + $ok = 1; + } + elsif( _dne($e1) xor _dne($e2) ) { $ok = 0; } - elsif ( $same_ref and ($e1 eq $e2) ) { + elsif( $same_ref and( $e1 eq $e2 ) ) { $ok = 1; } - elsif ( $not_ref ) { - push @Data_Stack, { type => '', vals => [$e1, $e2] }; - $ok = 0; - } + elsif($not_ref) { + push @Data_Stack, { type => '', vals => [ $e1, $e2 ] }; + $ok = 0; + } else { if( $Refs_Seen{$e1} ) { return $Refs_Seen{$e1} eq $e2; @@ -1250,50 +1413,48 @@ $type = 'DIFFERENT' unless _type($e2) eq $type; if( $type eq 'DIFFERENT' ) { - push @Data_Stack, { type => $type, vals => [$e1, $e2] }; + push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = 0; } elsif( $type eq 'ARRAY' ) { - $ok = _eq_array($e1, $e2); + $ok = _eq_array( $e1, $e2 ); } elsif( $type eq 'HASH' ) { - $ok = _eq_hash($e1, $e2); + $ok = _eq_hash( $e1, $e2 ); } elsif( $type eq 'REF' ) { - push @Data_Stack, { type => $type, vals => [$e1, $e2] }; - $ok = _deep_check($$e1, $$e2); + push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; + $ok = _deep_check( $$e1, $$e2 ); pop @Data_Stack if $ok; } elsif( $type eq 'SCALAR' ) { - push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; - $ok = _deep_check($$e1, $$e2); + push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] }; + $ok = _deep_check( $$e1, $$e2 ); pop @Data_Stack if $ok; } - elsif( $type ) { - push @Data_Stack, { type => $type, vals => [$e1, $e2] }; + elsif($type) { + push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = 0; } - else { - _whoa(1, "No type in _deep_check"); - } + else { + _whoa( 1, "No type in _deep_check" ); + } } } return $ok; } - sub _whoa { - my($check, $desc) = @_; - if( $check ) { - die < my $is_eq = eq_hash(\%got, \%expected); @@ -1304,14 +1465,14 @@ =cut sub eq_hash { - local @Data_Stack; + local @Data_Stack = (); return _deep_check(@_); } sub _eq_hash { - my($a1, $a2) = @_; + my( $a1, $a2 ) = @_; - if( grep !_type($_) eq 'HASH', $a1, $a2 ) { + if( grep _type($_) ne 'HASH', $a1, $a2 ) { warn "eq_hash passed a non-hash ref"; return 0; } @@ -1320,12 +1481,12 @@ my $ok = 1; my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; - foreach my $k (keys %$bigger) { + foreach my $k ( keys %$bigger ) { my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; - push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] }; - $ok = _deep_check($e1, $e2); + push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] }; + $ok = _deep_check( $e1, $e2 ); pop @Data_Stack if $ok; last unless $ok; @@ -1356,18 +1517,17 @@ eq_set([\1, \2], [\2, \1]); -Test::Deep contains much better set comparison functions. +L contains much better set comparison functions. =cut -sub eq_set { - my($a1, $a2) = @_; +sub eq_set { + my( $a1, $a2 ) = @_; return 0 unless @$a1 == @$a2; - # There's faster ways to do this, but this is easiest. - local $^W = 0; + no warnings 'uninitialized'; - # It really doesn't matter how we sort them, as long as both arrays are + # It really doesn't matter how we sort them, as long as both arrays are # sorted with the same algorithm. # # Ensure that references are not accidentally treated the same as a @@ -1379,8 +1539,8 @@ # I don't know how references would be sorted so we just don't sort # them. This means eq_set doesn't really work with refs. return eq_array( - [grep(ref, @$a1), sort( grep(!ref, @$a1) )], - [grep(ref, @$a2), sort( grep(!ref, @$a2) )], + [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ], + [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ], ); } @@ -1438,7 +1598,25 @@ =item Backwards compatibility -Test::More works with Perls as old as 5.004_05. +Test::More works with Perls as old as 5.6.0. + + +=item utf8 / "Wide character in print" + +If you use utf8 or other non-ASCII characters with Test::More you +might get a "Wide character in print" warning. Using C will not fix it. Test::Builder (which powers +Test::More) duplicates STDOUT and STDERR. So any changes to them, +including changing their output disciplines, will not be seem by +Test::More. + +The work around is to change the filehandles used by Test::Builder +directly. + + my $builder = Test::More->builder; + binmode $builder->output, ":utf8"; + binmode $builder->failure_output, ":utf8"; + binmode $builder->todo_output, ":utf8"; =item Overloaded objects @@ -1452,7 +1630,7 @@ However, it does mean that functions like is_deeply() cannot be used to test the internals of string overloaded objects. In this case I would -suggest Test::Deep which contains more flexible testing functions for +suggest L which contains more flexible testing functions for complex data structures. @@ -1474,11 +1652,11 @@ =item Test::Harness upgrade -no_plan and todo depend on new Test::Harness features and fixes. If -you're going to distribute tests that use no_plan or todo your -end-users will have to upgrade Test::Harness to the latest one on -CPAN. If you avoid no_plan and TODO tests, the stock Test::Harness -will work fine. +no_plan, todo and done_testing() depend on new Test::Harness features +and fixes. If you're going to distribute tests that use no_plan or +todo your end-users will have to upgrade Test::Harness to the latest +one on CPAN. If you avoid no_plan and TODO tests, the stock +Test::Harness will work fine. Installing Test::More should also upgrade Test::Harness. @@ -1506,21 +1684,21 @@ some tests. You can upgrade to Test::More later (it's forward compatible). -L is the old testing module. Its main benefit is that it has -been distributed with Perl since 5.004_05. - -L for details on how your test results are interpreted -by Perl. +L is the test runner and output interpreter for Perl. +It's the thing that powers C and where the C utility +comes from. + +L tests written with Test.pm, the original testing +module, do not play well with other testing libraries. Test::Legacy +emulates the Test.pm interface and does play well with others. L for more ways to test complex data structures. And it plays well with Test::More. -L is like XUnit but more perlish. +L is like xUnit but more perlish. L gives you more powerful complex data structure testing. -L is XUnit style testing. - L shows the idea of embedded testing. L installs a whole bunch of useful test modules. @@ -1539,9 +1717,15 @@ See F to report and view bugs. +=head1 SOURCE + +The source code repository for Test::More can be found at +F. + + =head1 COPYRIGHT -Copyright 2001-2002, 2004-2006 by Michael G Schwern Eschwern@pobox.comE. +Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff -urN perl-5.10.0.orig/lib/Test/Simple/Changes perl-5.10.0/lib/Test/Simple/Changes --- perl-5.10.0.orig/lib/Test/Simple/Changes 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/Changes 2009-08-26 06:14:11.000000000 +0200 @@ -1,8 +1,226 @@ +0.92 Fri Jul 3 11:08:56 PDT 2009 + Test Fixes + * Silence noise on VMS in exit.t (Craig Berry) + * Skip Builder/fork_with_new_stdout.t on systems without fork (Craig Berry) + + +0.90 Thu Jul 2 13:18:25 PDT 2009 + Docs + * Finally added a note about the "Wide character in print" warning and + how to work around it. + * Note the IO::Stringy license in our copy of it. + [test-more.googlecode.com 47] + + Test Fixes + * Small fixes for integration with the Perl core + [bleadperl eaa0815147e13cd4ab5b3d6ca8f26544a9f0c3b4] + * exit code tests could be effected by errno when PERLIO=stdio + [bleadperl c76230386fc5e6fba9fdbeab473abbf4f4adcbe3] + + Other + * This is a stable release for 5.10.1. It does not include + the subtest() work in 0.89_01. + + +0.88 Sat May 30 12:31:24 PDT 2009 + Turing 0.87_03 into a stable release. + + +0.87_03 Sun May 24 13:41:40 PDT 2009 + New Features + * isa_ok() now works on classes. (Peter Scott) + + +0.87_02 Sat Apr 11 12:54:14 PDT 2009 + Test Fixes + * Some filesystems don't like it when you open a file for writing multiple + times. Fixes t/Builder/reset.t. [rt.cpan.org 17298] + * Check how an operating system is going to map exit codes. Some OS' + will map them... sometimes. [rt.cpan.org 42148] + * Fix Test::Builder::NoOutput on 5.6.2. + + +0.87_01 Sun Mar 29 09:56:52 BST 2009 + New Features + * done_testing() allows you to declare that you have finished running tests, + and how many you ran. It is a safer no_plan and effectively replaces it. + * output() now supports scalar references. + + Feature Changes + * You can now run a test without first declaring a plan. This allows + done_testing() to work. + * You can now call current_test() without first declaring a plan. + + Bug Fixes + * skip_all() with no reason would output "1..0" which is invalid TAP. It will + now always include the SKIP directive. + + Other + * Repository moved to github. + + +0.86 Sun Nov 9 01:09:05 PST 2008 + Same as 0.85_01 + + +0.85_01 Thu Oct 23 18:57:38 PDT 2008 + New Features + * cmp_ok() now displays the error if the comparison throws one. + For example, broken overloaded objects. + + Bug Fixes + * cmp_ok() no longer stringifies or numifies its arguments before comparing. + This makes cmp_ok() properly test overloaded ops. + [rt.cpan.org 24186] [code.google.com 16] + * diag() properly escapes blank lines. + + Feature Changes + * cmp_ok() now reports warnings and errors as coming from inside cmp_ok, + as well as reporting the caller's file and line. This let's the user + know where cmp_ok() was called from while reminding them that it is + being run in a different context. + + Other + * Dependency on ExtUtils::MakeMaker 6.27 only on Windows otherwise the + nested tests won't run. + + +0.84 Wed Oct 15 09:06:12 EDT 2008 + Other + * 0.82 accidentally shipped with experimental Mouse dependency. + + +0.82 Tue Oct 14 23:06:56 EDT 2008 + Bug Fixes + - 0.81_01 broke $TODO such that $TODO = '' was considered todo. + + +0.81_02 Tue Sep 9 04:35:40 PDT 2008 + New Features + * Test::Builder->reset_outputs() to reset all the output methods back to + their defaults. + + Bug Fixes + - Fixed the file and line number reported by like when it gets a bad + regex. + + Features Changed + - Now preserves the tests' exit code if it exits abnormally, rather than + setting it to 255. + - Changed the "Looks like your test died" message to + "Looks like your test exited with $exit_code" + - no_plan now only warns if given an argument. There were a lot of people + doing that, and it's a sensible mistake. [test-more.googlecode.com 13] + + +0.81_01 Sat Sep 6 15:13:50 PDT 2008 + New Features + * Adam Kennedy bribed me to add new_ok(). The price was one DEFCON license key. + [rt.cpan.org 8891] + * TODO tests can now start and end with 'todo_start' and 'todo_end' + Test::Builder methods. [rt.cpan.org 38018] + * Added Test::Builder->in_todo() for a safe way to check if a test is inside a + TODO block. This allows TODO tests with no reason. + * Added note() and explain() to both Test::More and Test::Builder. + [rt.cpan.org 14764] [test-more.googlecode.com 3] + + Features Changed + * Changed the message for extra tests run to show the number of tests run rather than + the number extra to avoid the user having to do mental math. + [rt.cpan.org 7022] + + Bug fixes + - using a relative path to perl broke tests [rt.cpan.org 34050] + - use_ok() broke $SIG{__DIE__} in the used module [rt.cpan.org 34065] + - diagnostics for isnt() were confusing on failure [rt.cpan.org 33642] + - warnings when MakeMaker's version contained _ [rt.cpan.org 33626] + - add explicit test that non-integer plans die correctly [rt.cpan.org 28836] + (Thanks to Hans Dieter Pearcey [confound] for fixing the above) + - die if no_plan is given an argument [rt.cpan.org 27429] + + +0.80 Sun Apr 6 17:25:01 CEST 2008 + Test fixes + - Completely disable the utf8 test. It was causing perl to panic on some OS's. + + +0.79_01 Wed Feb 27 03:04:54 PST 2008 + Bug fixes + - Let's try the IO layer copying again, this time with the test + fixed for 5.10. + + +0.78 Wed Feb 27 01:59:09 PST 2008 + Bug fixes + * Whoops, the version of Test::Builder::Tester got moved backwards. + + +0.77 Wed Feb 27 01:55:55 PST 2008 + Bug fixes + - "use Test::Builder::Module" no longer sets exported_to() or does + any other importing. + - Fix the $TODO finding code so it can find $TODO without the benefit + of exported_to(), which is often wrong. + - Turn off the filehandle locale stuff for the moment, there's a + problem on 5.10. We'll try it again next release. + + Doc improvements + - Improve the Test::Builder SYNOPSIS to use Test::Builder::Module + rather than write it's own import(). + + +0.76_02 Sun Feb 24 13:12:55 PST 2008 + Bug fixes + * The default test output filehandles will NOT use utf8. + They will now copy the IO layers from STDOUT and STDERR. + This means if :utf8 is on then it will honor it and not + warn about wide characters. + + +0.76_01 Sat Feb 23 20:44:32 PST 2008 + Bug fixes + * Test::Builder no longer uses a __DIE__ handler. This resolves a number + of problems with exit codes being swallowed or other module's handlers + being interfered with. [rt.cpan.org 25294] + - Allow maybe_regex() to detect blessed regexes. [bleadperl @32880] + - The default test output filehandles will now use utf8. + [rt.cpan.org 21091] + + Test fixes + - Remove the signature test. Adds no security and just generates + failures. + + +0.75 Sat Feb 23 19:03:38 PST 2008 + Incompatibilities + * The minimum version is now 5.6.0. + + Bug fixes + - Turns out require_ok() had the same bug as use_ok() in a BEGIN block. + - ok() was not honoring exported_to() when looking for $TODO as it + should be. + + Test fixes + * is_deeply_with_threads.t will not run unless AUTHOR_TESTING is set. + This is because it tickles intermittent threading bugs in many perls + and causes a lot of bug reports about which I can do nothing. + + Misc + - Ran through perlcritic and did some cleaning. + +0.74 Thu Nov 29 15:39:57 PST 2007 + Misc + - Add abstract and author to the meta information. + +0.73_01 Mon Oct 15 20:35:15 EDT 2007 + Bug fixes + * Put the use_ok() fix from 0.71 back. + 0.72 Wed Sep 19 20:08:07 PDT 2007 Bug unfixes * The BEGIN { use_ok } fix for [rt.cpan.org 28345] revealed a small pile of - mistakes in CPAN module test suites. Rolling the fix back to give the authors - a bit of time to fix their tests. + mistakes in CPAN module test suites. Rolling the fix back to give the + authors a bit of time to fix their tests. 0.71 Thu Sep 13 20:42:36 PDT 2007 Bug fixes @@ -15,8 +233,8 @@ - Removed dependency on Text::Soundex [rt.cpan.org 25022] - Fixed a 5.5.x failure in fail-more.t * Got rid of the annoying sort_bug.t test that revealed problems with some - threaded perls. It was testing the deprecated eq_* functions and not worth the - bother. Now it tests is_deeply(). [rt.cpan.org 17791] + threaded perls. It was testing the deprecated eq_* functions and not + worth the bother. Now it tests is_deeply(). [rt.cpan.org 17791] Doc fixes - Minor POD mistake in Test::Builder [rt.cpan.org 28869] diff -urN perl-5.10.0.orig/lib/Test/Simple/README perl-5.10.0/lib/Test/Simple/README --- perl-5.10.0.orig/lib/Test/Simple/README 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/README 2009-08-26 06:14:11.000000000 +0200 @@ -13,3 +13,10 @@ make make test make install + +It requires Perl version 5.6.0 or newer and Test::Harness 2.03 or newer. + + +* More Info + +More information can be found at http://test-more.googlecode.com/ diff -urN perl-5.10.0.orig/lib/Test/Simple/t/bad_plan.t perl-5.10.0/lib/Test/Simple/t/bad_plan.t --- perl-5.10.0.orig/lib/Test/Simple/t/bad_plan.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/bad_plan.t 2009-08-26 06:14:11.000000000 +0200 @@ -7,32 +7,17 @@ } } -my $test_num = 1; -# Utility testing functions. -sub ok ($;$) { - my($test, $name) = @_; - my $ok = ''; - $ok .= "not " unless $test; - $ok .= "ok $test_num"; - $ok .= " - $name" if defined $name; - $ok .= "\n"; - print $ok; - $test_num++; - - return $test; -} - - use Test::Builder; my $Test = Test::Builder->new; +$Test->plan( tests => 2 ); +$Test->level(0); -print "1..2\n"; +my $tb = Test::Builder->create; -eval { $Test->plan(7); }; -ok( $@ =~ /^plan\(\) doesn't understand 7/, 'bad plan()' ) || +eval { $tb->plan(7); }; +$Test->like( $@, qr/^plan\(\) doesn't understand 7/, 'bad plan()' ) || print STDERR "# $@"; -eval { $Test->plan(wibble => 7); }; -ok( $@ =~ /^plan\(\) doesn't understand wibble 7/, 'bad plan()' ) || +eval { $tb->plan(wibble => 7); }; +$Test->like( $@, qr/^plan\(\) doesn't understand wibble 7/, 'bad plan()' ) || print STDERR "# $@"; - diff -urN perl-5.10.0.orig/lib/Test/Simple/t/bail_out.t perl-5.10.0/lib/Test/Simple/t/bail_out.t --- perl-5.10.0.orig/lib/Test/Simple/t/bail_out.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/bail_out.t 2009-08-26 06:14:11.000000000 +0200 @@ -18,30 +18,22 @@ use Test::Builder; use Test::More; -use TieOut; -my $output = tie *FAKEOUT, 'TieOut'; +my $output; my $TB = Test::More->builder; -$TB->output(\*FAKEOUT); +$TB->output(\$output); my $Test = Test::Builder->create; $Test->level(0); -if( $] >= 5.005 ) { - $Test->plan(tests => 3); -} -else { - $Test->plan(skip_all => - 'CORE::GLOBAL::exit, introduced in 5.005, is needed for testing'); -} - +$Test->plan(tests => 3); plan tests => 4; BAIL_OUT("ROCKS FALL! EVERYONE DIES!"); -$Test->is_eq( $output->read, <<'OUT' ); +$Test->is_eq( $output, <<'OUT' ); 1..4 Bail out! ROCKS FALL! EVERYONE DIES! OUT diff -urN perl-5.10.0.orig/lib/Test/Simple/t/BEGIN_require_ok.t perl-5.10.0/lib/Test/Simple/t/BEGIN_require_ok.t --- perl-5.10.0.orig/lib/Test/Simple/t/BEGIN_require_ok.t 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/BEGIN_require_ok.t 2009-08-26 06:14:11.000000000 +0200 @@ -0,0 +1,27 @@ +#!/usr/bin/perl -w + +# Fixed a problem with BEGIN { use_ok or require_ok } silently failing when there's no +# plan set. [rt.cpan.org 28345] Thanks Adriano Ferreira and Yitzchak. + +use strict; + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use Test::More; + +my $result; +BEGIN { + $result = require_ok("strict"); +} + +ok $result, "require_ok ran"; + +done_testing(2); diff -urN perl-5.10.0.orig/lib/Test/Simple/t/BEGIN_use_ok.t perl-5.10.0/lib/Test/Simple/t/BEGIN_use_ok.t --- perl-5.10.0.orig/lib/Test/Simple/t/BEGIN_use_ok.t 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/BEGIN_use_ok.t 2009-08-26 06:14:11.000000000 +0200 @@ -0,0 +1,26 @@ +#!/usr/bin/perl -w + +# [rt.cpan.org 28345] +# +# A use_ok() inside a BEGIN block lacking a plan would be silently ignored. + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use Test::More; + +my $result; +BEGIN { + $result = use_ok("strict"); +} + +ok( $result, "use_ok() ran" ); +done_testing(2); + diff -urN perl-5.10.0.orig/lib/Test/Simple/t/c_flag.t perl-5.10.0/lib/Test/Simple/t/c_flag.t --- perl-5.10.0.orig/lib/Test/Simple/t/c_flag.t 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/c_flag.t 2009-08-26 06:14:11.000000000 +0200 @@ -0,0 +1,21 @@ +#!/usr/bin/perl -w + +# Test::More should not print anything when Perl is only doing +# a compile as with the -c flag or B::Deparse or perlcc. + +# HARNESS_ACTIVE=1 was causing an error with -c +{ + local $ENV{HARNESS_ACTIVE} = 1; + local $^C = 1; + + require Test::More; + Test::More->import(tests => 1); + + fail("This should not show up"); +} + +Test::More->builder->no_ending(1); + +print "1..1\n"; +print "ok 1\n"; + diff -urN perl-5.10.0.orig/lib/Test/Simple/t/cmp_ok.t perl-5.10.0/lib/Test/Simple/t/cmp_ok.t --- perl-5.10.0.orig/lib/Test/Simple/t/cmp_ok.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/cmp_ok.t 2009-08-26 06:14:11.000000000 +0200 @@ -3,7 +3,7 @@ BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; - @INC = ('../lib', 'lib'); + @INC = ('../lib', 'lib', '../lib/Test/Simple/t/lib'); } else { unshift @INC, 't/lib'; @@ -29,19 +29,19 @@ $expect{error} =~ s/ at .*\n?//; local $Test::Builder::Level = $Test::Builder::Level + 1; - my $ok = cmp_ok($left, $cmp, $right); - $TB->is_num(!!$ok, !!$expect{ok}); + my $ok = cmp_ok($left, $cmp, $right, "cmp_ok"); + $TB->is_num(!!$ok, !!$expect{ok}, " right return"); my $diag = $err->read; if( !$ok and $expect{error} ) { $diag =~ s/^# //mg; - $TB->like( $diag, "/\Q$expect{error}\E/" ); + $TB->like( $diag, qr/\Q$expect{error}\E/, " expected error" ); } elsif( $ok ) { - $TB->is_eq( $diag, '' ); + $TB->is_eq( $diag, '', " passed without diagnostic" ); } else { - $TB->ok(1); + $TB->ok(1, " failed without diagnostic"); } } @@ -49,6 +49,10 @@ use Test::More; Test::More->builder->no_ending(1); +require MyOverload; +my $cmp = Overloaded::Compare->new("foo", 42); +my $ify = Overloaded::Ify->new("bar", 23); + my @Tests = ( [1, '==', 1], [1, '==', 2], @@ -56,23 +60,12 @@ ["a", "eq", "a"], [1, "+", 1], [1, "-", 1], -); -# These don't work yet. -if( 0 ) { -#if( eval { require overload } ) { - require MyOverload; - - my $cmp = Overloaded::Compare->new("foo", 42); - my $ify = Overloaded::Ify->new("bar", 23); - - push @Tests, ( - [$cmp, '==', 42], - [$cmp, 'eq', "foo"], - [$ify, 'eq', "bar"], - [$ify, "==", 23], - ); -} + [$cmp, '==', 42], + [$cmp, 'eq', "foo"], + [$ify, 'eq', "bar"], + [$ify, "==", 23], +); plan tests => scalar @Tests; $TB->plan(tests => @Tests * 2); diff -urN perl-5.10.0.orig/lib/Test/Simple/t/create.t perl-5.10.0/lib/Test/Simple/t/create.t --- perl-5.10.0.orig/lib/Test/Simple/t/create.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/create.t 2009-08-26 06:14:11.000000000 +0200 @@ -12,8 +12,9 @@ } } -use Test::More tests => 8; +use Test::More tests => 7; use Test::Builder; +use Test::Builder::NoOutput; my $more_tb = Test::More->builder; isa_ok $more_tb, 'Test::Builder'; @@ -22,24 +23,18 @@ is $more_tb, Test::Builder->new, ' does not interfere with ->new'; { - my $new_tb = Test::Builder->create; + my $new_tb = Test::Builder::NoOutput->create; isa_ok $new_tb, 'Test::Builder'; isnt $more_tb, $new_tb, 'Test::Builder->create makes a new object'; - $new_tb->output("some_file"); - END { 1 while unlink "some_file" } - $new_tb->plan(tests => 1); - $new_tb->ok(1); -} - -pass("Changing output() of new TB doesn't interfere with singleton"); + $new_tb->ok(1, "a test"); -ok open FILE, "some_file"; -is join("", ), <read, <<'OUT'; 1..1 -ok 1 +ok 1 - a test OUT +} -close FILE; +pass("Changing output() of new TB doesn't interfere with singleton"); diff -urN perl-5.10.0.orig/lib/Test/Simple/t/current_test.t perl-5.10.0/lib/Test/Simple/t/current_test.t --- perl-5.10.0.orig/lib/Test/Simple/t/current_test.t 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/current_test.t 2009-08-26 06:14:11.000000000 +0200 @@ -0,0 +1,11 @@ +#!/usr/bin/perl -w + +# Dave Rolsky found a bug where if current_test() is used and no +# tests are run via Test::Builder it will blow up. + +use Test::Builder; +$TB = Test::Builder->new; +$TB->plan(tests => 2); +print "ok 1\n"; +print "ok 2\n"; +$TB->current_test(2); diff -urN perl-5.10.0.orig/lib/Test/Simple/t/current_test_without_plan.t perl-5.10.0/lib/Test/Simple/t/current_test_without_plan.t --- perl-5.10.0.orig/lib/Test/Simple/t/current_test_without_plan.t 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/current_test_without_plan.t 2009-08-26 06:14:11.000000000 +0200 @@ -0,0 +1,16 @@ +#!/usr/bin/perl -w + +# Test that current_test() will work without a declared plan. + +use Test::Builder; + +my $tb = Test::Builder->new; +$tb->current_test(2); +print <<'END'; +ok 1 +ok 2 +END + +$tb->ok(1, "Third test"); + +$tb->done_testing(3); diff -urN perl-5.10.0.orig/lib/Test/Simple/t/curr_test.t perl-5.10.0/lib/Test/Simple/t/curr_test.t --- perl-5.10.0.orig/lib/Test/Simple/t/curr_test.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/curr_test.t 1970-01-01 01:00:00.000000000 +0100 @@ -1,11 +0,0 @@ -#!/usr/bin/perl -w - -# Dave Rolsky found a bug where if current_test() is used and no -# tests are run via Test::Builder it will blow up. - -use Test::Builder; -$TB = Test::Builder->new; -$TB->plan(tests => 2); -print "ok 1\n"; -print "ok 2\n"; -$TB->current_test(2); diff -urN perl-5.10.0.orig/lib/Test/Simple/t/details.t perl-5.10.0/lib/Test/Simple/t/details.t --- perl-5.10.0.orig/lib/Test/Simple/t/details.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/details.t 2009-08-26 06:14:11.000000000 +0200 @@ -29,13 +29,11 @@ # Inline TODO tests will confuse pre 1.20 Test::Harness, so we # should just avoid the problem and not print it out. -my $out_fh = $Test->output; -my $todo_fh = $Test->todo_output; my $start_test = $Test->current_test + 1; -require TieOut; -tie *FH, 'TieOut'; -$Test->output(\*FH); -$Test->todo_output(\*FH); + +my $output = ''; +$Test->output(\$output); +$Test->todo_output(\$output); SKIP: { $Test->skip( 'just testing skip' ); @@ -68,8 +66,7 @@ }; for ($start_test..$Test->current_test) { print "ok $_\n" } -$Test->output($out_fh); -$Test->todo_output($todo_fh); +$Test->reset_outputs; $Test->is_num( scalar $Test->summary(), 4, 'summary' ); push @Expected_Details, { 'ok' => 1, diff -urN perl-5.10.0.orig/lib/Test/Simple/t/diag.t perl-5.10.0/lib/Test/Simple/t/diag.t --- perl-5.10.0.orig/lib/Test/Simple/t/diag.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/diag.t 2009-08-26 06:14:11.000000000 +0200 @@ -24,49 +24,58 @@ use strict; -use Test::More tests => 5; +use Test::Builder::NoOutput; +use Test::More tests => 7; -my $Test = Test::More->builder; +my $test = Test::Builder::NoOutput->create; -# now make a filehandle where we can send data -use TieOut; -my $output = tie *FAKEOUT, 'TieOut'; - -# force diagnostic output to a filehandle, glad I added this to -# Test::Builder :) -my $ret; +# Test diag() goes to todo_output() in a todo test. { - local $TODO = 1; - $Test->todo_output(\*FAKEOUT); - - diag("a single line"); - - $ret = diag("multiple\n", "lines"); -} + $test->todo_start(); -is( $output->read, <<'DIAG', 'diag() with todo_output set' ); + $test->diag("a single line"); + is( $test->read('todo'), <<'DIAG', 'diag() with todo_output set' ); # a single line +DIAG + + my $ret = $test->diag("multiple\n", "lines"); + is( $test->read('todo'), <<'DIAG', ' multi line' ); # multiple # lines DIAG + ok( !$ret, 'diag returns false' ); + + $test->todo_end(); +} -ok( !$ret, 'diag returns false' ); +# Test diagnostic formatting { - $Test->failure_output(\*FAKEOUT); - $ret = diag("# foo"); + $test->diag("# foo"); + is( $test->read('err'), "# # foo\n", "diag() adds # even if there's one already" ); + + $test->diag("foo\n\nbar"); + is( $test->read('err'), <<'DIAG', " blank lines get escaped" ); +# foo +# +# bar +DIAG + + $test->diag("foo\n\nbar\n\n"); + is( $test->read('err'), <<'DIAG', " even at the end" ); +# foo +# +# bar +# +DIAG } -$Test->failure_output(\*STDERR); -is( $output->read, "# # foo\n", "diag() adds # even if there's one already" ); -ok( !$ret, 'diag returns false' ); -# [rt.cpan.org 8392] +# [rt.cpan.org 8392] diag(@list) emulates print { - $Test->failure_output(\*FAKEOUT); - diag(qw(one two)); -} -$Test->failure_output(\*STDERR); -is( $output->read, <<'DIAG' ); + $test->diag(qw(one two)); + + is( $test->read('err'), <<'DIAG' ); # onetwo DIAG +} diff -urN perl-5.10.0.orig/lib/Test/Simple/t/died.t perl-5.10.0/lib/Test/Simple/t/died.t --- perl-5.10.0.orig/lib/Test/Simple/t/died.t 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/died.t 2009-08-26 06:14:11.000000000 +0200 @@ -0,0 +1,45 @@ +#!perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +# Can't use Test.pm, that's a 5.005 thing. +package My::Test; + +# This has to be a require or else the END block below runs before +# Test::Builder's own and the ending diagnostics don't come out right. +require Test::Builder; +my $TB = Test::Builder->create; +$TB->plan(tests => 3); + + +package main; + +require Test::Simple; + +chdir 't'; +push @INC, '../t/lib/'; +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); +local $ENV{HARNESS_ACTIVE} = 0; + +Test::Simple->import(tests => 1); +exit 250; + +END { + $TB->is_eq($out->read, <is_eq($err->read, <is_eq($?, 250, "exit code"); + + exit grep { !$_ } $TB->summary; +} diff -urN perl-5.10.0.orig/lib/Test/Simple/t/done_testing_double.t perl-5.10.0/lib/Test/Simple/t/done_testing_double.t --- perl-5.10.0.orig/lib/Test/Simple/t/done_testing_double.t 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/done_testing_double.t 2009-08-26 06:14:40.000000000 +0200 @@ -0,0 +1,46 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = qw(../lib lib ../lib/Test/Simple/t/lib); + } +} + +use strict; +use lib 't/lib'; + +use Test::Builder; +use Test::Builder::NoOutput; + +my $tb = Test::Builder::NoOutput->create; + +{ + # Normalize test output + local $ENV{HARNESS_ACTIVE}; + + $tb->ok(1); + $tb->ok(1); + $tb->ok(1); + +#line 24 + $tb->done_testing(3); + $tb->done_testing; + $tb->done_testing; +} + +my $Test = Test::Builder->new; +$Test->plan( tests => 1 ); +$Test->level(0); +$Test->is_eq($tb->read, <<"END", "multiple done_testing"); +ok 1 +ok 2 +ok 3 +1..3 +not ok 4 - done_testing() was already called at $0 line 24 +# Failed test 'done_testing() was already called at $0 line 24' +# at $0 line 25. +not ok 5 - done_testing() was already called at $0 line 24 +# Failed test 'done_testing() was already called at $0 line 24' +# at $0 line 26. +END diff -urN perl-5.10.0.orig/lib/Test/Simple/t/done_testing_plan_mismatch.t perl-5.10.0/lib/Test/Simple/t/done_testing_plan_mismatch.t --- perl-5.10.0.orig/lib/Test/Simple/t/done_testing_plan_mismatch.t 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/done_testing_plan_mismatch.t 2009-08-26 06:14:43.000000000 +0200 @@ -0,0 +1,44 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = qw(../lib lib ../lib/Test/Simple/t/lib); + } +} + +# What if there's a plan and done_testing but they don't match? + +use strict; +use lib 't/lib'; + +use Test::Builder; +use Test::Builder::NoOutput; + +my $tb = Test::Builder::NoOutput->create; + +{ + # Normalize test output + local $ENV{HARNESS_ACTIVE}; + + $tb->plan( tests => 3 ); + $tb->ok(1); + $tb->ok(1); + $tb->ok(1); + +#line 24 + $tb->done_testing(2); +} + +my $Test = Test::Builder->new; +$Test->plan( tests => 1 ); +$Test->level(0); +$Test->is_eq($tb->read, <<"END"); +1..3 +ok 1 +ok 2 +ok 3 +not ok 4 - planned to run 3 but done_testing() expects 2 +# Failed test 'planned to run 3 but done_testing() expects 2' +# at $0 line 24. +END diff -urN perl-5.10.0.orig/lib/Test/Simple/t/done_testing.t perl-5.10.0/lib/Test/Simple/t/done_testing.t --- perl-5.10.0.orig/lib/Test/Simple/t/done_testing.t 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/done_testing.t 2009-08-26 06:14:11.000000000 +0200 @@ -0,0 +1,12 @@ +#!/usr/bin/perl -w + +use strict; + +use Test::Builder; + +my $tb = Test::Builder->new; +$tb->level(0); + +$tb->ok(1, "testing done_testing() with no arguments"); +$tb->ok(1, " another test so we're not testing just one"); +$tb->done_testing(); diff -urN perl-5.10.0.orig/lib/Test/Simple/t/done_testing_with_no_plan.t perl-5.10.0/lib/Test/Simple/t/done_testing_with_no_plan.t --- perl-5.10.0.orig/lib/Test/Simple/t/done_testing_with_no_plan.t 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/done_testing_with_no_plan.t 2009-08-26 06:14:11.000000000 +0200 @@ -0,0 +1,11 @@ +#!/usr/bin/perl -w + +use strict; + +use Test::Builder; + +my $tb = Test::Builder->new; +$tb->plan( "no_plan" ); +$tb->ok(1); +$tb->ok(1); +$tb->done_testing(2); diff -urN perl-5.10.0.orig/lib/Test/Simple/t/done_testing_with_number.t perl-5.10.0/lib/Test/Simple/t/done_testing_with_number.t --- perl-5.10.0.orig/lib/Test/Simple/t/done_testing_with_number.t 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/done_testing_with_number.t 2009-08-26 06:14:11.000000000 +0200 @@ -0,0 +1,12 @@ +#!/usr/bin/perl -w + +use strict; + +use Test::Builder; + +my $tb = Test::Builder->new; +$tb->level(0); + +$tb->ok(1, "testing done_testing() with no arguments"); +$tb->ok(1, " another test so we're not testing just one"); +$tb->done_testing(2); diff -urN perl-5.10.0.orig/lib/Test/Simple/t/done_testing_with_plan.t perl-5.10.0/lib/Test/Simple/t/done_testing_with_plan.t --- perl-5.10.0.orig/lib/Test/Simple/t/done_testing_with_plan.t 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/done_testing_with_plan.t 2009-08-26 06:14:11.000000000 +0200 @@ -0,0 +1,11 @@ +#!/usr/bin/perl -w + +use strict; + +use Test::Builder; + +my $tb = Test::Builder->new; +$tb->plan( tests => 2 ); +$tb->ok(1); +$tb->ok(1); +$tb->done_testing(2); diff -urN perl-5.10.0.orig/lib/Test/Simple/t/dont_overwrite_die_handler.t perl-5.10.0/lib/Test/Simple/t/dont_overwrite_die_handler.t --- perl-5.10.0.orig/lib/Test/Simple/t/dont_overwrite_die_handler.t 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/dont_overwrite_die_handler.t 2009-08-26 06:14:11.000000000 +0200 @@ -0,0 +1,19 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +# Make sure this is in place before Test::More is loaded. +my $handler_called; +BEGIN { + $SIG{__DIE__} = sub { $handler_called++ }; +} + +use Test::More tests => 2; + +ok !eval { die }; +is $handler_called, 1, 'existing DIE handler not overridden'; diff -urN perl-5.10.0.orig/lib/Test/Simple/t/exit.t perl-5.10.0/lib/Test/Simple/t/exit.t --- perl-5.10.0.orig/lib/Test/Simple/t/exit.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/exit.t 2009-08-26 06:14:11.000000000 +0200 @@ -10,59 +10,27 @@ } } -unless( eval { require File::Spec } ) { - print "1..0 # Skip Need File::Spec to run this test\n"; - exit 0; -} - -if( $^O eq 'VMS' && $] <= 5.00503 ) { - print "1..0 # Skip test will hang on older VMS perls\n"; - exit 0; -} - -if( $^O eq 'MacOS' ) { - print "1..0 # Skip exit status broken on Mac OS\n"; - exit 0; -} - -my $test_num = 1; -# Utility testing functions. -sub ok ($;$) { - my($test, $name) = @_; - my $ok = ''; - $ok .= "not " unless $test; - $ok .= "ok $test_num"; - $ok .= " - $name" if defined $name; - $ok .= "\n"; - print $ok; - $test_num++; -} +require Test::Builder; +my $TB = Test::Builder->create(); +$TB->level(0); package main; -my $IsVMS = $^O eq 'VMS'; +use Cwd; +use File::Spec; -print "# Ahh! I see you're running VMS.\n" if $IsVMS; +my $Orig_Dir = cwd; -my %Tests = ( - # Everyone Else VMS - 'success.plx' => [0, 0], - 'one_fail.plx' => [1, 4], - 'two_fail.plx' => [2, 4], - 'five_fail.plx' => [5, 4], - 'extras.plx' => [2, 4], - 'too_few.plx' => [255, 4], - 'too_few_fail.plx' => [2, 4], - 'death.plx' => [255, 4], - 'last_minute_death.plx' => [255, 4], - 'pre_plan_death.plx' => ['not zero', 'not zero'], - 'death_in_eval.plx' => [0, 0], - 'require.plx' => [0, 0], - 'exit.plx' => [1, 4], - ); +my $Perl = File::Spec->rel2abs($^X); +if( $^O eq 'VMS' ) { + # VMS can't use its own $^X in a system call until almost 5.8 + $Perl = "MCR $^X" if $] < 5.007003; + + # Quiet noisy 'SYS$ABORT' + $Perl .= q{ -"Mvmsish=hushed"}; +} -print "1..".keys(%Tests)."\n"; eval { require POSIX; &POSIX::WEXITSTATUS(0) }; if( $@ ) { @@ -72,34 +40,74 @@ *exitstatus = sub { POSIX::WEXITSTATUS($_[0]) } } -chdir 't'; -my $lib = File::Spec->catdir(qw(lib Test Simple sample_tests)); -while( my($test_name, $exit_codes) = each %Tests ) { - my($exit_code) = $exit_codes->[$IsVMS ? 1 : 0]; - my $Perl = $^X; +# Some OS' will alter the exit code to their own native sense... +# sometimes. Rather than deal with the exception we'll just +# build up the mapping. +print "# Building up a map of exit codes. May take a while.\n"; +my %Exit_Map; + +open my $fh, ">", "exit_map_test" or die $!; +print $fh <<'DONE'; +if ($^O eq 'VMS') { + require vmsish; + import vmsish qw(hushed); +} +my $exit = shift; +print "exit $exit\n"; +END { $? = $exit }; +DONE + +close $fh; +END { 1 while unlink "exit_map_test" } + +for my $exit (0..255) { + # This correctly emulates Test::Builder's behavior. + my $out = qx[$Perl exit_map_test $exit]; + $TB->like( $out, qr/^exit $exit\n/, "exit map test for $exit" ); + $Exit_Map{$exit} = exitstatus($?); +} +print "# Done.\n"; + - if( $^O eq 'VMS' ) { - # VMS can't use its own $^X in a system call until almost 5.8 - $Perl = "MCR $^X" if $] < 5.007003; - - # Quiet noisy 'SYS$ABORT'. 'hushed' only exists in 5.6 and up, - # but it doesn't do any harm on eariler perls. - $Perl .= q{ -"Mvmsish=hushed"}; - } +my %Tests = ( + # File Exit Code + 'success.plx' => 0, + 'one_fail.plx' => 1, + 'two_fail.plx' => 2, + 'five_fail.plx' => 5, + 'extras.plx' => 2, + 'too_few.plx' => 255, + 'too_few_fail.plx' => 2, + 'death.plx' => 255, + 'last_minute_death.plx' => 255, + 'pre_plan_death.plx' => 'not zero', + 'death_in_eval.plx' => 0, + 'require.plx' => 0, + 'death_with_handler.plx' => 255, + 'exit.plx' => 1, + ); +chdir 't'; +my $lib = File::Spec->catdir(qw(lib Test Simple sample_tests)); +while( my($test_name, $exit_code) = each %Tests ) { my $file = File::Spec->catfile($lib, $test_name); my $wait_stat = system(qq{$Perl -"I../blib/lib" -"I../lib" -"I../t/lib" $file}); my $actual_exit = exitstatus($wait_stat); if( $exit_code eq 'not zero' ) { - My::Test::ok( $actual_exit != 0, + $TB->isnt_num( $actual_exit, $Exit_Map{0}, "$test_name exited with $actual_exit ". - "(expected $exit_code)"); + "(expected non-zero)"); } else { - My::Test::ok( $actual_exit == $exit_code, + $TB->is_num( $actual_exit, $Exit_Map{$exit_code}, "$test_name exited with $actual_exit ". - "(expected $exit_code)"); + "(expected $Exit_Map{$exit_code})"); } } + +$TB->done_testing( scalar keys(%Tests) + 256 ); + +# So any END block file cleanup works. +chdir $Orig_Dir; diff -urN perl-5.10.0.orig/lib/Test/Simple/t/explain.t perl-5.10.0/lib/Test/Simple/t/explain.t --- perl-5.10.0.orig/lib/Test/Simple/t/explain.t 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/explain.t 2009-08-26 06:14:11.000000000 +0200 @@ -0,0 +1,27 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; +use warnings; + +use Test::More tests => 5; + +can_ok "main", "explain"; + +is_deeply [explain("foo")], ["foo"]; +is_deeply [explain("foo", "bar")], ["foo", "bar"]; + +# Avoid future dump formatting changes from breaking tests by just eval'ing +# the dump +is_deeply [map { eval $_ } explain([], {})], [[], {}]; + +is_deeply [map { eval $_ } explain(23, [42,91], 99)], [23, [42, 91], 99]; diff -urN perl-5.10.0.orig/lib/Test/Simple/t/extra_one.t perl-5.10.0/lib/Test/Simple/t/extra_one.t --- perl-5.10.0.orig/lib/Test/Simple/t/extra_one.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/extra_one.t 2009-08-26 06:14:11.000000000 +0200 @@ -44,7 +44,7 @@ OUT My::Test::is($$err, <create; -$TB->plan(tests => 2); +$TB->plan(tests => 4); require Test::Simple::Catch; @@ -43,11 +36,10 @@ require Test::More; Test::More->import(tests => 1); -eval q{ like( "foo", qr/that/, 'is foo like that' ); }; - +{ + eval q{ like( "foo", qr/that/, 'is foo like that' ); }; -END { - $TB->is_eq($$out, <is_eq($out->read, <like($err->read, qr/^$err_re$/, 'failing errors'); +} - $TB->like($$err, qr/^$err_re$/, 'failing errors'); +{ + # line 59 + like("foo", "not a regex"); + $TB->is_eq($out->read, <is_eq($err->read, <summary); } diff -urN perl-5.10.0.orig/lib/Test/Simple/t/fail-more.t perl-5.10.0/lib/Test/Simple/t/fail-more.t --- perl-5.10.0.orig/lib/Test/Simple/t/fail-more.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/fail-more.t 2009-08-26 06:14:11.000000000 +0200 @@ -24,7 +24,7 @@ # Test::Builder's own and the ending diagnostics don't come out right. require Test::Builder; my $TB = Test::Builder->create; -$TB->plan(tests => 17); +$TB->plan(tests => 78); sub like ($$;$) { $TB->like(@_); @@ -34,19 +34,26 @@ $TB->is_eq(@_); } -sub main::err_ok ($) { - my($expect) = @_; - my $got = $err->read; +sub main::out_ok ($$) { + $TB->is_eq( $out->read, shift ); + $TB->is_eq( $err->read, shift ); +} + +sub main::out_like ($$) { + my($output, $failure) = @_; - return $TB->is_eq( $got, $expect ); + $TB->like( $out->read, qr/$output/ ); + $TB->like( $err->read, qr/$failure/ ); } package main; require Test::More; -my $Total = 30; +our $TODO; +my $Total = 37; Test::More->import(tests => $Total); +$out->read; # clear the plan from $out # This should all work in the presence of a __DIE__ handler. local $SIG{__DIE__} = sub { $TB->ok(0, "DIE handler called: ".join "", @_); }; @@ -57,184 +64,387 @@ my $Filename = quotemeta $0; -# Preserve the line numbers. + #line 38 ok( 0, 'failing' ); -err_ok( <can(...) +OUT # Failed test 'Mooble::Hooble::Yooble->can(...)' -# at $0 line 52. +# at $0 line 197. # Mooble::Hooble::Yooble->can('this') failed # Mooble::Hooble::Yooble->can('that') failed +ERR + +#line 208 +can_ok('Mooble::Hooble::Yooble', ()); +out_ok( <can(...) +OUT # Failed test 'Mooble::Hooble::Yooble->can(...)' -# at $0 line 53. +# at $0 line 208. # can_ok() called with no methods +ERR + +#line 218 +can_ok(undef, undef); +out_ok( <can(...) +OUT # Failed test '->can(...)' -# at $0 line 54. +# at $0 line 218. # can_ok() called with empty class or reference +ERR + +#line 228 +can_ok([], "foo"); +out_ok( <can('foo') +OUT # Failed test 'ARRAY->can('foo')' -# at $0 line 55. +# at $0 line 228. # ARRAY->can('foo') failed ERR -#line 55 +#line 238 isa_ok(bless([], "Foo"), "Wibble"); -isa_ok(42, "Wibble", "My Wibble"); -isa_ok(undef, "Wibble", "Another Wibble"); -isa_ok([], "HASH"); -err_ok( <is_eq( $out->read, <is_eq( $err->read, <read, "/^$more_err_re/"); - - -#line 85 +#line 460 require_ok('ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble'); $more_err_re = <read, "/^$more_err_re/"); +out_like( + qr/^\Qnot ok - require ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble;\E\n\z/, + qr/^$more_err_re/ +); -#line 88 END { - $TB->is_eq($$out, <can(...) -not ok - Mooble::Hooble::Yooble->can(...) -not ok - ->can(...) -not ok - ARRAY->can('foo') -not ok - The object isa Wibble -not ok - My Wibble isa Wibble -not ok - Another Wibble isa Wibble -not ok - The object isa HASH -not ok - cmp_ok eq -not ok - == -not ok - != -not ok - && -not ok - eq with numbers -not ok - == with strings -not ok - eq with stringified errno -not ok - eq with numerified errno -not ok - use Hooble::mooble::yooble; -not ok - require ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble; + out_like( <new; -print "1..2\n"; +{ + my $tb = Test::Builder::NoOutput->create; -my $test_num = 1; -# Utility testing functions. -sub ok ($;$) { - my($test, $name) = @_; - my $ok = ''; - $ok .= "not " unless $test; - $ok .= "ok $test_num"; - $ok .= " - $name" if defined $name; - $ok .= "\n"; - print $ok; - $test_num++; + $tb->plan( tests => 1 ); - return $test ? 1 : 0; -} - - -package main; - -require Test::Simple; -Test::Simple->import(tests => 1); - -#line 45 -ok(0); +#line 28 + $tb->ok(0); + $tb->_ending; -END { - My::Test::ok($$out eq <is_eq($tb->read('out'), <is_eq($tb->read('err'), <done_testing(2); } diff -urN perl-5.10.0.orig/lib/Test/Simple/t/fail.t perl-5.10.0/lib/Test/Simple/t/fail.t --- perl-5.10.0.orig/lib/Test/Simple/t/fail.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/fail.t 2009-08-26 06:14:11.000000000 +0200 @@ -1,5 +1,7 @@ #!perl -w +# Simple test of what failure output looks like + BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @@ -12,45 +14,28 @@ use strict; -require Test::Simple::Catch; -my($out, $err) = Test::Simple::Catch::caught(); +# Normalize the output whether we're running under Test::Harness or not. local $ENV{HARNESS_ACTIVE} = 0; +use Test::Builder; +use Test::Builder::NoOutput; -# Can't use Test.pm, that's a 5.005 thing. -package My::Test; - -print "1..2\n"; - -my $test_num = 1; -# Utility testing functions. -sub ok ($;$) { - my($test, $name) = @_; - my $ok = ''; - $ok .= "not " unless $test; - $ok .= "ok $test_num"; - $ok .= " - $name" if defined $name; - $ok .= "\n"; - print $ok; - $test_num++; -} - - -package main; - -require Test::Simple; -Test::Simple->import(tests => 5); - -#line 35 -ok( 1, 'passing' ); -ok( 2, 'passing still' ); -ok( 3, 'still passing' ); -ok( 0, 'oh no!' ); -ok( 0, 'damnit' ); +my $Test = Test::Builder->new; +# Set up a builder to record some failing tests. +{ + my $tb = Test::Builder::NoOutput->create; + $tb->plan( tests => 5 ); + +#line 28 + $tb->ok( 1, 'passing' ); + $tb->ok( 2, 'passing still' ); + $tb->ok( 3, 'still passing' ); + $tb->ok( 0, 'oh no!' ); + $tb->ok( 0, 'damnit' ); + $tb->_ending; -END { - My::Test::ok($$out eq <is_eq($tb->read('out'), <is_eq($tb->read('err'), <done_testing(2); } diff -urN perl-5.10.0.orig/lib/Test/Simple/t/filehandles.t perl-5.10.0/lib/Test/Simple/t/filehandles.t --- perl-5.10.0.orig/lib/Test/Simple/t/filehandles.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/filehandles.t 2009-08-26 06:14:11.000000000 +0200 @@ -3,19 +3,16 @@ BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; - @INC = '../lib'; + @INC = ('../lib', 'lib'); } } +use lib 't/lib'; use Test::More tests => 1; +use Dev::Null; tie *STDOUT, "Dev::Null" or die $!; print "not ok 1\n"; # this should not print. pass 'STDOUT can be mucked with'; - -package Dev::Null; - -sub TIEHANDLE { bless {} } -sub PRINT { 1 } diff -urN perl-5.10.0.orig/lib/Test/Simple/t/fork_with_new_stdout.t perl-5.10.0/lib/Test/Simple/t/fork_with_new_stdout.t --- perl-5.10.0.orig/lib/Test/Simple/t/fork_with_new_stdout.t 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/fork_with_new_stdout.t 2009-08-26 06:14:11.000000000 +0200 @@ -0,0 +1,54 @@ +#!perl -w +use strict; +use warnings; +use IO::Pipe; +use Test::Builder; +use Config; + +my $b = Test::Builder->new; +$b->reset; + +my $Can_Fork = $Config{d_fork} || + (($^O eq 'MSWin32' || $^O eq 'NetWare') and + $Config{useithreads} and + $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/ + ); + +if( !$Can_Fork ) { + $b->plan('skip_all' => "This system cannot fork"); +} +else { + $b->plan('tests' => 2); +} + +my $pipe = IO::Pipe->new; +if ( my $pid = fork ) { + $pipe->reader; + $b->ok((<$pipe> =~ /FROM CHILD: ok 1/), "ok 1 from child"); + $b->ok((<$pipe> =~ /FROM CHILD: 1\.\.1/), "1..1 from child"); + waitpid($pid, 0); +} +else { + $pipe->writer; + my $pipe_fd = $pipe->fileno; + close STDOUT; + open(STDOUT, ">&$pipe_fd"); + my $b = Test::Builder->new; + $b->reset; + $b->no_plan; + $b->ok(1); +} + + +=pod +#actual +1..2 +ok 1 +1..1 +ok 1 +ok 2 +#expected +1..2 +ok 1 +ok 2 +=cut diff -urN perl-5.10.0.orig/lib/Test/Simple/t/is_deeply_dne_bug.t perl-5.10.0/lib/Test/Simple/t/is_deeply_dne_bug.t --- perl-5.10.0.orig/lib/Test/Simple/t/is_deeply_dne_bug.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/is_deeply_dne_bug.t 2009-08-26 06:14:11.000000000 +0200 @@ -16,16 +16,7 @@ } use strict; -use Test::More; - -BEGIN { - if( !eval "require overload" ) { - plan skip_all => "needs overload.pm"; - } - else { - plan tests => 2; - } -} +use Test::More tests => 2; { package Foo; diff -urN perl-5.10.0.orig/lib/Test/Simple/t/is_deeply_fail.t perl-5.10.0/lib/Test/Simple/t/is_deeply_fail.t --- perl-5.10.0.orig/lib/Test/Simple/t/is_deeply_fail.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/is_deeply_fail.t 2009-08-26 06:14:11.000000000 +0200 @@ -317,7 +317,8 @@ ERR - if( eval { require overload } ) { + # Overloaded object tests + { my $foo = bless [], "Foo"; my $bar = bless {}, "Bar"; @@ -337,9 +338,6 @@ ERR } - else { - $TB->skip("Needs overload.pm") for 1..3; - } } diff -urN perl-5.10.0.orig/lib/Test/Simple/t/is_deeply_with_threads.t perl-5.10.0/lib/Test/Simple/t/is_deeply_with_threads.t --- perl-5.10.0.orig/lib/Test/Simple/t/is_deeply_with_threads.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/is_deeply_with_threads.t 2009-08-26 06:14:11.000000000 +0200 @@ -19,7 +19,12 @@ unless ( $] >= 5.008001 && $Config{'useithreads'} && eval { require threads; 'threads'->import; 1; }) { - print "1..0 # Skip: no working threads\n"; + print "1..0 # Skip no working threads\n"; + exit 0; + } + + unless ( $ENV{AUTHOR_TESTING} ) { + print "1..0 # Skip many perls have broken threads. Enable with AUTHOR_TESTING.\n"; exit 0; } } @@ -27,7 +32,7 @@ my $Num_Threads = 5; -plan tests => $Num_Threads * 100 + 5; +plan tests => $Num_Threads * 100 + 6; sub do_one_thread { @@ -56,3 +61,5 @@ my $rc = $t->join(); cmp_ok( $rc, '==', 42, "threads exit status is $rc" ); } + +pass("End of test"); diff -urN perl-5.10.0.orig/lib/Test/Simple/t/lib/Dev/Null.pm perl-5.10.0/lib/Test/Simple/t/lib/Dev/Null.pm --- perl-5.10.0.orig/lib/Test/Simple/t/lib/Dev/Null.pm 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/lib/Dev/Null.pm 2009-08-26 06:14:11.000000000 +0200 @@ -0,0 +1,8 @@ +package Dev::Null; + +use strict; + +sub TIEHANDLE { bless {}, shift } +sub PRINT { 1 } + +1; diff -urN perl-5.10.0.orig/lib/Test/Simple/t/lib/Dummy.pm perl-5.10.0/lib/Test/Simple/t/lib/Dummy.pm --- perl-5.10.0.orig/lib/Test/Simple/t/lib/Dummy.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/lib/Dummy.pm 2009-08-26 06:14:11.000000000 +0200 @@ -1,5 +1,6 @@ package Dummy; -$VERSION = '0.01'; +use strict; +our $VERSION = '0.01'; -1; \ No newline at end of file +1; diff -urN perl-5.10.0.orig/lib/Test/Simple/t/lib/MyOverload.pm perl-5.10.0/lib/Test/Simple/t/lib/MyOverload.pm --- perl-5.10.0.orig/lib/Test/Simple/t/lib/MyOverload.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/lib/MyOverload.pm 2009-08-26 06:14:11.000000000 +0200 @@ -1,29 +1,30 @@ -package Overloaded; +package Overloaded; ##no critic (Modules::RequireFilenameMatchesPackage) + +use strict; sub new { my $class = shift; bless { string => shift, num => shift }, $class; } - package Overloaded::Compare; -use vars qw(@ISA); -@ISA = qw(Overloaded); + +use strict; +our @ISA = qw(Overloaded); # Sometimes objects have only comparison ops overloaded and nothing else. # For example, DateTime objects. use overload - q{eq} => sub { $_[0]->{string} eq $_[1] }, - q{==} => sub { $_[0]->{num} == $_[1] }; - - + q{eq} => sub { $_[0]->{string} eq $_[1] }, + q{==} => sub { $_[0]->{num} == $_[1] }; package Overloaded::Ify; -use vars qw(@ISA); -@ISA = qw(Overloaded); + +use strict; +our @ISA = qw(Overloaded); use overload - q{""} => sub { $_[0]->{string} }, - q{0+} => sub { $_[0]->{num} }; + q{""} => sub { $_[0]->{string} }, + q{0+} => sub { $_[0]->{num} }; -1; \ No newline at end of file +1; diff -urN perl-5.10.0.orig/lib/Test/Simple/t/lib/SigDie.pm perl-5.10.0/lib/Test/Simple/t/lib/SigDie.pm --- perl-5.10.0.orig/lib/Test/Simple/t/lib/SigDie.pm 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/lib/SigDie.pm 2009-08-26 06:14:11.000000000 +0200 @@ -0,0 +1,8 @@ +package SigDie; + +use strict; + +our $DIE; +$SIG{__DIE__} = sub { $DIE = $@ }; + +1; diff -urN perl-5.10.0.orig/lib/Test/Simple/t/maybe_regex.t perl-5.10.0/lib/Test/Simple/t/maybe_regex.t --- perl-5.10.0.orig/lib/Test/Simple/t/maybe_regex.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/maybe_regex.t 2009-08-26 06:14:11.000000000 +0200 @@ -11,22 +11,24 @@ } use strict; -use Test::More tests => 13; +use Test::More tests => 16; use Test::Builder; my $Test = Test::Builder->new; -SKIP: { - skip "qr// added in 5.005", 3 if $] < 5.005; +my $r = $Test->maybe_regex(qr/^FOO$/i); +ok(defined $r, 'qr// detected'); +ok(('foo' =~ /$r/), 'qr// good match'); +ok(('bar' !~ /$r/), 'qr// bad match'); - # 5.004 can't even see qr// or it pukes in compile. - eval q{ - my $r = $Test->maybe_regex(qr/^FOO$/i); - ok(defined $r, 'qr// detected'); - ok(('foo' =~ /$r/), 'qr// good match'); - ok(('bar' !~ /$r/), 'qr// bad match'); - }; - die $@ if $@; +SKIP: { + skip "blessed regex checker added in 5.10", 3 if $] < 5.010; + + my $obj = bless qr/foo/, 'Wibble'; + my $re = $Test->maybe_regex($obj); + ok( defined $re, "blessed regex detected" ); + ok( ('foo' =~ /$re/), 'blessed qr/foo/ good match' ); + ok( ('bar' !~ /$re/), 'blessed qr/foo/ bad math' ); } { diff -urN perl-5.10.0.orig/lib/Test/Simple/t/missing.t perl-5.10.0/lib/Test/Simple/t/missing.t --- perl-5.10.0.orig/lib/Test/Simple/t/missing.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/missing.t 2009-08-26 06:14:11.000000000 +0200 @@ -33,19 +33,23 @@ #line 30 ok(1, 'Foo'); ok(0, 'Bar'); +ok(1, '1 2 3'); END { My::Test::is($$out, < 52; +use Test::More tests => 53; # Make sure we don't mess with $@ or $!. Test at bottom. my $Err = "this should not be touched"; @@ -47,6 +47,11 @@ isa_ok(bless([], "Foo"), "Foo"); isa_ok([], 'ARRAY'); isa_ok(\42, 'SCALAR'); +{ + local %Bar::; + local @Foo::ISA = 'Bar'; + isa_ok( "Foo", "Bar" ); +} # can_ok() & isa_ok should call can() & isa() on the given object, not diff -urN perl-5.10.0.orig/lib/Test/Simple/t/new_ok.t perl-5.10.0/lib/Test/Simple/t/new_ok.t --- perl-5.10.0.orig/lib/Test/Simple/t/new_ok.t 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/new_ok.t 2009-08-26 06:14:11.000000000 +0200 @@ -0,0 +1,42 @@ +#!/usr/bin/perl -w + +use strict; + +use Test::More tests => 13; + +{ + package Bar; + + sub new { + my $class = shift; + return bless {@_}, $class; + } + + + package Foo; + our @ISA = qw(Bar); +} + +{ + my $obj = new_ok("Foo"); + is_deeply $obj, {}; + isa_ok $obj, "Foo"; + + $obj = new_ok("Bar"); + is_deeply $obj, {}; + isa_ok $obj, "Bar"; + + $obj = new_ok("Foo", [this => 42]); + is_deeply $obj, { this => 42 }; + isa_ok $obj, "Foo"; + + $obj = new_ok("Foo", [], "Foo"); + is_deeply $obj, {}; + isa_ok $obj, "Foo"; +} + +# And what if we give it nothing? +eval { + new_ok(); +}; +is $@, sprintf "new_ok() must be given at least a class at %s line %d.\n", $0, __LINE__ - 2; diff -urN perl-5.10.0.orig/lib/Test/Simple/t/no_plan_at_all.t perl-5.10.0/lib/Test/Simple/t/no_plan_at_all.t --- perl-5.10.0.orig/lib/Test/Simple/t/no_plan_at_all.t 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/no_plan_at_all.t 2009-08-26 06:14:44.000000000 +0200 @@ -0,0 +1,35 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = qw(../lib lib ../lib/Test/Simple/t/lib); + } +} + +# Test what happens when no plan is delcared and done_testing() is not seen + +use strict; +use lib 't/lib'; + +use Test::Builder; +use Test::Builder::NoOutput; + +my $Test = Test::Builder->new; +$Test->level(0); +$Test->plan( tests => 1 ); + +my $tb = Test::Builder::NoOutput->create; + +{ + $tb->level(0); + $tb->ok(1, "just a test"); + $tb->ok(1, " and another"); + $tb->_ending; +} + +$Test->is_eq($tb->read, <<'END', "proper behavior when no plan is seen"); +ok 1 - just a test +ok 2 - and another +# Tests were run but no plan was declared and done_testing() was not seen. +END diff -urN perl-5.10.0.orig/lib/Test/Simple/t/no_plan.t perl-5.10.0/lib/Test/Simple/t/no_plan.t --- perl-5.10.0.orig/lib/Test/Simple/t/no_plan.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/no_plan.t 2009-08-26 06:14:11.000000000 +0200 @@ -10,19 +10,24 @@ } } -use Test::More tests => 6; +use Test::More tests => 7; my $tb = Test::Builder->create; -$tb->level(0); -#line 19 +#line 20 ok !eval { $tb->plan(tests => undef) }; -is($@, "Got an undefined number of tests at $0 line 19.\n"); +is($@, "Got an undefined number of tests at $0 line 20.\n"); -#line 23 +#line 24 ok !eval { $tb->plan(tests => 0) }; -is($@, "You said to run 0 tests at $0 line 23.\n"); +is($@, "You said to run 0 tests at $0 line 24.\n"); -#line 27 -ok !eval { $tb->ok(1) }; -is( $@, "You tried to run a test without a plan at $0 line 27.\n"); +{ + my $warning = ''; + local $SIG{__WARN__} = sub { $warning .= join '', @_ }; + +#line 31 + ok $tb->plan(no_plan => 1); + is( $warning, "no_plan takes no arguments at $0 line 31.\n" ); + is $tb->has_plan, 'no_plan'; +} diff -urN perl-5.10.0.orig/lib/Test/Simple/t/no_tests.t perl-5.10.0/lib/Test/Simple/t/no_tests.t --- perl-5.10.0.orig/lib/Test/Simple/t/no_tests.t 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/no_tests.t 2009-08-26 06:14:11.000000000 +0200 @@ -0,0 +1,44 @@ +#!perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +# Can't use Test.pm, that's a 5.005 thing. +package My::Test; + +# This has to be a require or else the END block below runs before +# Test::Builder's own and the ending diagnostics don't come out right. +require Test::Builder; +my $TB = Test::Builder->create; +$TB->plan(tests => 3); + + +package main; + +require Test::Simple; + +chdir 't'; +push @INC, '../t/lib/'; +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); +local $ENV{HARNESS_ACTIVE} = 0; + +Test::Simple->import(tests => 1); + +END { + $TB->is_eq($out->read, <is_eq($err->read, <is_eq($?, 255, "exit code"); + + exit grep { !$_ } $TB->summary; +} diff -urN perl-5.10.0.orig/lib/Test/Simple/t/note.t perl-5.10.0/lib/Test/Simple/t/note.t --- perl-5.10.0.orig/lib/Test/Simple/t/note.t 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/note.t 2009-08-26 06:14:11.000000000 +0200 @@ -0,0 +1,30 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; +use warnings; + +use Test::Builder::NoOutput; + +use Test::More tests => 2; + +{ + my $tb = Test::Builder::NoOutput->create; + + $tb->note("foo"); + + $tb->reset_outputs; + + is $tb->read('out'), "# foo\n"; + is $tb->read('err'), ''; +} + diff -urN perl-5.10.0.orig/lib/Test/Simple/t/output.t perl-5.10.0/lib/Test/Simple/t/output.t --- perl-5.10.0.orig/lib/Test/Simple/t/output.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/output.t 2009-08-26 06:14:11.000000000 +0200 @@ -1,5 +1,7 @@ #!perl -w +use strict; + BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @@ -11,76 +13,91 @@ } chdir 't'; +use Test::Builder; -# Can't use Test.pm, that's a 5.005 thing. -print "1..4\n"; +# The real Test::Builder +my $Test = Test::Builder->new; +$Test->plan( tests => 6 ); -my $test_num = 1; -# Utility testing functions. -sub ok ($;$) { - my($test, $name) = @_; - my $ok = ''; - $ok .= "not " unless $test; - $ok .= "ok $test_num"; - $ok .= " - $name" if defined $name; - $ok .= "\n"; - print $ok; - $test_num++; - return $test; -} - -use TieOut; -use Test::Builder; -my $Test = Test::Builder->new(); +# The one we're going to test. +my $tb = Test::Builder->create(); -my $result; my $tmpfile = 'foo.tmp'; -my $out = $Test->output($tmpfile); END { 1 while unlink($tmpfile) } -ok( defined $out ); +# Test output to a file +{ + my $out = $tb->output($tmpfile); + $Test->ok( defined $out ); + + print $out "hi!\n"; + close *$out; + + undef $out; + open(IN, $tmpfile) or die $!; + chomp(my $line = ); + close IN; + + $Test->is_eq($line, 'hi!'); +} -print $out "hi!\n"; -close *$out; -undef $out; -open(IN, $tmpfile) or die $!; -chomp(my $line = ); -close IN; - -ok($line eq 'hi!'); - -open(FOO, ">>$tmpfile") or die $!; -$out = $Test->output(\*FOO); -$old = select *$out; -print "Hello!\n"; -close *$out; -undef $out; -select $old; -open(IN, $tmpfile) or die $!; -my @lines = ; -close IN; +# Test output to a filehandle +{ + open(FOO, ">>$tmpfile") or die $!; + my $out = $tb->output(\*FOO); + my $old = select *$out; + print "Hello!\n"; + close *$out; + undef $out; + select $old; + open(IN, $tmpfile) or die $!; + my @lines = ; + close IN; -ok($lines[1] =~ /Hello!/); + $Test->like($lines[1], qr/Hello!/); +} +# Test output to a scalar ref +{ + my $scalar = ''; + my $out = $tb->output(\$scalar); + + print $out "Hey hey hey!\n"; + $Test->is_eq($scalar, "Hey hey hey!\n"); +} + + +# Test we can output to the same scalar ref +{ + my $scalar = ''; + my $out = $tb->output(\$scalar); + my $err = $tb->failure_output(\$scalar); + + print $out "To output "; + print $err "and beyond!"; + + $Test->is_eq($scalar, "To output and beyond!", "One scalar, two filehandles"); +} + # Ensure stray newline in name escaping works. -$out = tie *FAKEOUT, 'TieOut'; -$Test->output(\*FAKEOUT); -$Test->exported_to(__PACKAGE__); -$Test->no_ending(1); -$Test->plan(tests => 5); - -$Test->ok(1, "ok"); -$Test->ok(1, "ok\n"); -$Test->ok(1, "ok, like\nok"); -$Test->skip("wibble\nmoof"); -$Test->todo_skip("todo\nskip\n"); +{ + my $fakeout = ''; + my $out = $tb->output(\$fakeout); + $tb->exported_to(__PACKAGE__); + $tb->no_ending(1); + $tb->plan(tests => 5); + + $tb->ok(1, "ok"); + $tb->ok(1, "ok\n"); + $tb->ok(1, "ok, like\nok"); + $tb->skip("wibble\nmoof"); + $tb->todo_skip("todo\nskip\n"); -my $output = $out->read; -ok( $output eq <is_eq( $fakeout, < "needs overload.pm"; - } - else { - plan tests => 13; - } -} +use Test::More tests => 19; package Overloaded; use overload - q{""} => sub { $_[0]->{string} }, - q{0+} => sub { $_[0]->{num} }; + q{eq} => sub { $_[0]->{string} eq $_[1] }, + q{==} => sub { $_[0]->{num} == $_[1] }, + q{""} => sub { $_[0]->{stringify}++; $_[0]->{string} }, + q{0+} => sub { $_[0]->{numify}++; $_[0]->{num} } +; sub new { my $class = shift; - bless { string => shift, num => shift }, $class; + bless { + string => shift, + num => shift, + stringify => 0, + numify => 0, + }, $class; } @@ -46,9 +45,11 @@ my $obj = Overloaded->new('foo', 42); isa_ok $obj, 'Overloaded'; -is $obj, 'foo', 'is() with string overloading'; -cmp_ok $obj, 'eq', 'foo', 'cmp_ok() ...'; -cmp_ok $obj, '==', 42, 'cmp_ok() with number overloading'; +cmp_ok $obj, 'eq', 'foo', 'cmp_ok() eq'; +is $obj->{stringify}, 0, ' does not stringify'; +is $obj, 'foo', 'is() with string overloading'; +cmp_ok $obj, '==', 42, 'cmp_ok() with number overloading'; +is $obj->{numify}, 0, ' does not numify'; is_deeply [$obj], ['foo'], 'is_deeply with string overloading'; ok eq_array([$obj], ['foo']), 'eq_array ...'; @@ -72,3 +73,14 @@ {'TestPackage' => 'TestPackage'}); ::is_deeply('TestPackage', 'TestPackage'); } + + +# Make sure 0 isn't a special case. [rt.cpan.org 41109] +{ + my $obj = Overloaded->new('0', 42); + isa_ok $obj, 'Overloaded'; + + cmp_ok $obj, 'eq', '0', 'cmp_ok() eq'; + is $obj->{stringify}, 0, ' does not stringify'; + is $obj, '0', 'is() with string overloading'; +} diff -urN perl-5.10.0.orig/lib/Test/Simple/t/overload_threads.t perl-5.10.0/lib/Test/Simple/t/overload_threads.t --- perl-5.10.0.orig/lib/Test/Simple/t/overload_threads.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/overload_threads.t 2009-08-26 06:14:11.000000000 +0200 @@ -17,16 +17,7 @@ eval { require threads; 'threads'->import; 1; }; } -use Test::More; - -BEGIN { - if( !eval "require overload" ) { - plan skip_all => "needs overload.pm"; - } - else { - plan tests => 5; - } -} +use Test::More tests => 5; package Overloaded; diff -urN perl-5.10.0.orig/lib/Test/Simple/t/plan_bad.t perl-5.10.0/lib/Test/Simple/t/plan_bad.t --- perl-5.10.0.orig/lib/Test/Simple/t/plan_bad.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/plan_bad.t 2009-08-26 06:14:11.000000000 +0200 @@ -8,7 +8,7 @@ } -use Test::More tests => 10; +use Test::More tests => 12; use Test::Builder; my $tb = Test::Builder->create; $tb->level(0); @@ -21,6 +21,9 @@ ok !eval { $tb->plan( tests => @foo ) }; is $@, sprintf "Number of tests must be a positive integer. You gave it '$foo' at %s line %d.\n", $0, __LINE__ - 1; +ok !eval { $tb->plan( tests => 9.99 ) }; +is $@, sprintf "Number of tests must be a positive integer. You gave it '9.99' at %s line %d.\n", $0, __LINE__ - 1; + #line 25 ok !eval { $tb->plan( tests => -1 ) }; is $@, "Number of tests must be a positive integer. You gave it '-1' at $0 line 25.\n"; diff -urN perl-5.10.0.orig/lib/Test/Simple/t/plan_is_noplan.t perl-5.10.0/lib/Test/Simple/t/plan_is_noplan.t --- perl-5.10.0.orig/lib/Test/Simple/t/plan_is_noplan.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/plan_is_noplan.t 2009-08-26 06:14:11.000000000 +0200 @@ -1,3 +1,5 @@ +#!/usr/bin/perl -w + BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @@ -8,47 +10,23 @@ } } -# Can't use Test.pm, that's a 5.005 thing. -package My::Test; - -print "1..2\n"; - -my $test_num = 1; -# Utility testing functions. -sub ok ($;$) { - my($test, $name) = @_; - my $ok = ''; - $ok .= "not " unless $test; - $ok .= "ok $test_num"; - $ok .= " - $name" if defined $name; - $ok .= "\n"; - print $ok; - $test_num++; -} - +use strict; -package main; +use Test::More tests => 1; -require Test::Simple; +use Test::Builder::NoOutput; -require Test::Simple::Catch; -my($out, $err) = Test::Simple::Catch::caught(); +{ + my $tb = Test::Builder::NoOutput->create; + $tb->plan('no_plan'); -Test::Simple->import('no_plan'); + $tb->ok(1, 'foo'); + $tb->_ending; -ok(1, 'foo'); - - -END { - My::Test::ok($$out eq <read, <create(); + + # Store the original output filehandles and change them all. + my %original_outputs; + + open my $fh, ">", "dummy_file.tmp"; + END { 1 while unlink "dummy_file.tmp"; } + for my $method (qw(output failure_output todo_output)) { + $original_outputs{$method} = $tb->$method(); + $tb->$method($fh); + is $tb->$method(), $fh; + } + + $tb->reset_outputs; + + for my $method (qw(output failure_output todo_output)) { + is $tb->$method(), $original_outputs{$method}, "reset_outputs() resets $method"; + } +} diff -urN perl-5.10.0.orig/lib/Test/Simple/t/reset.t perl-5.10.0/lib/Test/Simple/t/reset.t --- perl-5.10.0.orig/lib/Test/Simple/t/reset.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/reset.t 2009-08-26 06:14:11.000000000 +0200 @@ -15,19 +15,23 @@ use Test::Builder; -my $tb = Test::Builder->new; -$tb->plan(tests => 14); -$tb->level(0); +my $Test = Test::Builder->new; +my $tb = Test::Builder->create; + +# We'll need this later to know the outputs were reset +my %Original_Output; +$Original_Output{$_} = $tb->$_ for qw(output failure_output todo_output); # Alter the state of Test::Builder as much as possible. -$tb->ok(1, "Running a test to alter TB's state"); +my $output = ''; +$tb->output(\$output); +$tb->failure_output(\$output); +$tb->todo_output(\$output); -my $tmpfile = 'foo.tmp'; +$tb->plan(tests => 14); +$tb->level(0); -$tb->output($tmpfile); -$tb->failure_output($tmpfile); -$tb->todo_output($tmpfile); -END { 1 while unlink $tmpfile } +$tb->ok(1, "Running a test to alter TB's state"); # This won't print since we just sent output off to oblivion. $tb->ok(0, "And a failure for fun"); @@ -44,41 +48,26 @@ # Now reset it. $tb->reset; -my $test_num = 2; # since we already printed 1 -# Utility testing functions. -sub ok ($;$) { - my($test, $name) = @_; - my $ok = ''; - $ok .= "not " unless $test; - $ok .= "ok $test_num"; - $ok .= " - $name" if defined $name; - $ok .= "\n"; - print $ok; - $test_num++; - - return $test; -} - - -ok( !defined $tb->exported_to, 'exported_to' ); -ok( $tb->expected_tests == 0, 'expected_tests' ); -ok( $tb->level == 1, 'level' ); -ok( $tb->use_numbers == 1, 'use_numbers' ); -ok( $tb->no_header == 0, 'no_header' ); -ok( $tb->no_ending == 0, 'no_ending' ); -ok( fileno $tb->output == fileno *Test::Builder::TESTOUT, - 'output' ); -ok( fileno $tb->failure_output == fileno *Test::Builder::TESTERR, - 'failure_output' ); -ok( fileno $tb->todo_output == fileno *Test::Builder::TESTOUT, - 'todo_output' ); -ok( $tb->current_test == 0, 'current_test' ); -ok( $tb->summary == 0, 'summary' ); -ok( $tb->details == 0, 'details' ); -$tb->no_ending(1); -$tb->no_header(1); -$tb->plan(tests => 14); -$tb->current_test(13); +$Test->ok( !defined $tb->exported_to, 'exported_to' ); +$Test->is_eq( $tb->expected_tests, 0, 'expected_tests' ); +$Test->is_eq( $tb->level, 1, 'level' ); +$Test->is_eq( $tb->use_numbers, 1, 'use_numbers' ); +$Test->is_eq( $tb->no_header, 0, 'no_header' ); +$Test->is_eq( $tb->no_ending, 0, 'no_ending' ); +$Test->is_eq( $tb->current_test, 0, 'current_test' ); +$Test->is_eq( scalar $tb->summary, 0, 'summary' ); +$Test->is_eq( scalar $tb->details, 0, 'details' ); +$Test->is_eq( fileno $tb->output, + fileno $Original_Output{output}, 'output' ); +$Test->is_eq( fileno $tb->failure_output, + fileno $Original_Output{failure_output}, 'failure_output' ); +$Test->is_eq( fileno $tb->todo_output, + fileno $Original_Output{todo_output}, 'todo_output' ); + +$tb->current_test(12); $tb->level(0); $tb->ok(1, 'final test to make sure output was reset'); + +$Test->current_test(13); +$Test->done_testing(13); diff -urN perl-5.10.0.orig/lib/Test/Simple/t/skipall.t perl-5.10.0/lib/Test/Simple/t/skipall.t --- perl-5.10.0.orig/lib/Test/Simple/t/skipall.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/skipall.t 2009-08-26 06:14:11.000000000 +0200 @@ -1,3 +1,5 @@ +#!/usr/bin/perl -w + BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @@ -10,35 +12,22 @@ use strict; -# Can't use Test.pm, that's a 5.005 thing. -package My::Test; - -print "1..2\n"; - -my $test_num = 1; -# Utility testing functions. -sub ok ($;$) { - my($test, $name) = @_; - my $ok = ''; - $ok .= "not " unless $test; - $ok .= "ok $test_num"; - $ok .= " - $name" if defined $name; - $ok .= "\n"; - print $ok; - $test_num++; -} +use Test::More; +my $Test = Test::Builder->create; +$Test->plan(tests => 2); -package main; -require Test::More; - -require Test::Simple::Catch; -my($out, $err) = Test::Simple::Catch::caught(); - -Test::More->import('skip_all'); +my $out = ''; +my $err = ''; +{ + my $tb = Test::More->builder; + $tb->output(\$out); + $tb->failure_output(\$err); + plan 'skip_all'; +} END { - My::Test::ok($$out eq "1..0\n"); - My::Test::ok($$err eq ""); + $Test->is_eq($out, "1..0 # SKIP\n"); + $Test->is_eq($err, ""); } diff -urN perl-5.10.0.orig/lib/Test/Simple/t/skip.t perl-5.10.0/lib/Test/Simple/t/skip.t --- perl-5.10.0.orig/lib/Test/Simple/t/skip.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/skip.t 2009-08-26 06:14:11.000000000 +0200 @@ -94,5 +94,5 @@ pass "This does not run"; } - like $warning, '/^skip\(\) was passed a non-numeric number of tests/'; + like $warning, qr/^skip\(\) was passed a non-numeric number of tests/; } diff -urN perl-5.10.0.orig/lib/Test/Simple/t/tbm_doesnt_set_exported_to.t perl-5.10.0/lib/Test/Simple/t/tbm_doesnt_set_exported_to.t --- perl-5.10.0.orig/lib/Test/Simple/t/tbm_doesnt_set_exported_to.t 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/tbm_doesnt_set_exported_to.t 2009-08-26 06:14:11.000000000 +0200 @@ -0,0 +1,24 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +use strict; +use warnings; + +# Can't use Test::More, that would set exported_to() +use Test::Builder; +use Test::Builder::Module; + +my $TB = Test::Builder->create; +$TB->plan( tests => 1 ); +$TB->level(0); + +$TB->is_eq( Test::Builder::Module->builder->exported_to, + undef, + 'using Test::Builder::Module does not set exported_to()' +); diff -urN perl-5.10.0.orig/lib/Test/Simple/t/thread_taint.t perl-5.10.0/lib/Test/Simple/t/thread_taint.t --- perl-5.10.0.orig/lib/Test/Simple/t/thread_taint.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/thread_taint.t 2009-08-26 06:14:11.000000000 +0200 @@ -2,4 +2,4 @@ use Test::More tests => 1; -ok( !$INC{'threads.pm'}, 'Loading Test::More does not load threads.pm' ); \ No newline at end of file +ok( !$INC{'threads.pm'}, 'Loading Test::More does not load threads.pm' ); diff -urN perl-5.10.0.orig/lib/Test/Simple/t/todo.t perl-5.10.0/lib/Test/Simple/t/todo.t --- perl-5.10.0.orig/lib/Test/Simple/t/todo.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/todo.t 2009-08-26 06:14:11.000000000 +0200 @@ -9,7 +9,7 @@ use Test::More; -plan tests => 18; +plan tests => 36; $Why = 'Just testing the todo interface.'; @@ -42,7 +42,7 @@ ok( 'this' eq 'that', 'ok' ); - like( 'this', '/that/', 'like' ); + like( 'this', qr/that/, 'like' ); is( 'this', 'that', 'is' ); isnt( 'this', 'this', 'isnt' ); @@ -69,11 +69,89 @@ # perl gets the line number a little wrong on the first # statement inside a block. 1 == 1; -#line 82 +#line 74 todo_skip "Just testing todo_skip"; fail("So very failed"); } is( $warning, "todo_skip() needs to know \$how_many tests are in the ". - "block at $0 line 82\n", + "block at $0 line 74\n", 'todo_skip without $how_many warning' ); } + +my $builder = Test::More->builder; +my $exported_to = $builder->exported_to; +TODO: { + $builder->exported_to("Wibble"); + + local $TODO = "testing \$TODO with an incorrect exported_to()"; + + fail("Just testing todo"); +} + +$builder->exported_to($exported_to); + +$builder->todo_start('Expected failures'); +fail('Testing todo_start()'); +ok 0, 'Testing todo_start() with more than one failure'; +$is_todo = $builder->todo; +$builder->todo_end; +is $is_todo, 'Expected failures', + 'todo_start should have the correct TODO message'; +ok 1, 'todo_end() should not leak TODO behavior'; + +my @nested_todo; +my ( $level1, $level2 ) = ( 'failure level 1', 'failure_level 2' ); +TODO: { + local $TODO = 'Nesting TODO'; + fail('fail 1'); + + $builder->todo_start($level1); + fail('fail 2'); + + push @nested_todo => $builder->todo; + $builder->todo_start($level2); + fail('fail 3'); + + push @nested_todo => $builder->todo; + $builder->todo_end; + fail('fail 4'); + + push @nested_todo => $builder->todo; + $builder->todo_end; + $is_todo = $builder->todo; + fail('fail 4'); +} +is_deeply \@nested_todo, [ $level1, $level2, $level1 ], + 'Nested TODO message should be correct'; +is $is_todo, 'Nesting TODO', + '... and original TODO message should be correct'; + +{ + $builder->todo_start; + fail("testing todo_start() with no message"); + my $reason = $builder->todo; + my $in_todo = $builder->in_todo; + $builder->todo_end; + + is $reason, '', " todo() reports no reason"; + ok $in_todo, " but we're in_todo()"; +} + +eval { + $builder->todo_end; +}; +is $@, sprintf "todo_end() called without todo_start() at %s line %d.\n", $0, __LINE__ - 2; + + +{ + my($reason, $in_todo); + + TODO: { + local $TODO = ''; + $reason = $builder->todo; + $in_todo = $builder->in_todo; + } + + is $reason, ''; + ok !$in_todo, '$TODO = "" is not considered TODO'; +} diff -urN perl-5.10.0.orig/lib/Test/Simple/t/try.t perl-5.10.0/lib/Test/Simple/t/try.t --- perl-5.10.0.orig/lib/Test/Simple/t/try.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/try.t 2009-08-26 06:14:11.000000000 +0200 @@ -17,19 +17,26 @@ require Test::Builder; my $tb = Test::Builder->new; -local $SIG{__DIE__} = sub { fail("DIE handler called: @_") }; -# These should not change; -local $@ = 42; -local $! = 23; - -is $tb->_try(sub { 2 }), 2; -is $tb->_try(sub { return '' }), ''; - -is $tb->_try(sub { die; }), undef; - -is_deeply [$tb->_try(sub { die "Foo\n" }, undef)], - [undef, "Foo\n"]; - -is $@, 42; -cmp_ok $!, '==', 23; \ No newline at end of file +# Test that _try() has no effect on $@ and $! and is not effected by +# __DIE__ +{ + local $SIG{__DIE__} = sub { fail("DIE handler called: @_") }; + local $@ = 42; + local $! = 23; + + is $tb->_try(sub { 2 }), 2; + is $tb->_try(sub { return '' }), ''; + + is $tb->_try(sub { die; }), undef; + + is_deeply [$tb->_try(sub { die "Foo\n" })], [undef, "Foo\n"]; + + is $@, 42; + cmp_ok $!, '==', 23; +} + +ok !eval { + $tb->_try(sub { die "Died\n" }, die_on_fail => 1); +}; +is $@, "Died\n"; diff -urN perl-5.10.0.orig/lib/Test/Simple/t/undef.t perl-5.10.0/lib/Test/Simple/t/undef.t --- perl-5.10.0.orig/lib/Test/Simple/t/undef.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/undef.t 2009-08-26 06:14:11.000000000 +0200 @@ -11,8 +11,7 @@ } use strict; -use Test::More tests => 18; -use TieOut; +use Test::More tests => 21; BEGIN { $^W = 1; } @@ -31,7 +30,7 @@ } sub warnings_like { - $TB->like($warnings, "/$_[0]/"); + $TB->like($warnings, $_[0]); $warnings = ''; } @@ -48,9 +47,12 @@ isnt( undef, '', 'undef isnt an empty string' ); isnt( undef, 0, 'undef isnt zero' ); +Test::More->builder->is_num(undef, undef, 'is_num()'); +Test::More->builder->isnt_num(23, undef, 'isnt_num()'); + #line 45 -like( undef, '/.*/', 'undef is like anything' ); -warnings_like("Use of uninitialized value.* at $Filename line 45\\.\n"); +like( undef, qr/.*/, 'undef is like anything' ); +warnings_like(qr/Use of uninitialized value.* at $Filename line 45\.\n/); eq_array( [undef, undef], [undef, 23] ); no_warnings; @@ -70,23 +72,27 @@ #line 64 cmp_ok( undef, '<=', 2, ' undef <= 2' ); -warnings_like("Use of uninitialized value.* at $Filename line 64\\.\n"); +warnings_like(qr/Use of uninitialized value.* at cmp_ok \[from $Filename line 64\] line 1\.\n/); my $tb = Test::More->builder; -use TieOut; -my $caught = tie *CATCH, 'TieOut'; -my $old_fail = $tb->failure_output; -$tb->failure_output(\*CATCH); +my $err; +$tb->failure_output(\$err); diag(undef); -$tb->failure_output($old_fail); +$tb->reset_outputs; -is( $caught->read, "# undef\n" ); +is( $err, "# undef\n" ); no_warnings; $tb->maybe_regex(undef); -is( $caught->read, '' ); no_warnings; + + +# test-more.googlecode.com #42 +{ + is_deeply([ undef ], [ undef ]); + no_warnings; +} diff -urN perl-5.10.0.orig/lib/Test/Simple/t/use_ok.t perl-5.10.0/lib/Test/Simple/t/use_ok.t --- perl-5.10.0.orig/lib/Test/Simple/t/use_ok.t 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/use_ok.t 2009-08-26 06:16:36.000000000 +0200 @@ -3,14 +3,14 @@ BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; - @INC = ('../lib', 'lib'); + @INC = qw(../lib lib ../lib/Test/Simple/t/lib); } else { unshift @INC, 't/lib'; } } -use Test::More tests => 13; +use Test::More tests => 15; # Using Symbol because it's core and exports lots of stuff. { @@ -58,3 +58,10 @@ }; ::use_ok("Test::More", 0.47); } + +{ + package Foo::eight; + local $SIG{__DIE__}; + ::use_ok("SigDie"); + ::ok(defined $SIG{__DIE__}, ' SIG{__DIE__} preserved'); +} diff -urN perl-5.10.0.orig/lib/Test/Simple/t/utf8.t perl-5.10.0/lib/Test/Simple/t/utf8.t --- perl-5.10.0.orig/lib/Test/Simple/t/utf8.t 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/utf8.t 2009-08-26 06:14:11.000000000 +0200 @@ -0,0 +1,69 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +use strict; +use warnings; + +use Test::More skip_all => 'Not yet implemented'; + +my $have_perlio; +BEGIN { + # All together so Test::More sees the open discipline + $have_perlio = eval q[ + use PerlIO; + use open ':std', ':locale'; + use Test::More; + 1; + ]; +} + +use Test::More; + +if( !$have_perlio ) { + plan skip_all => "Don't have PerlIO"; +} +else { + plan tests => 5; +} + +SKIP: { + skip( "Need PerlIO for this feature", 3 ) + unless $have_perlio; + + my %handles = ( + output => \*STDOUT, + failure_output => \*STDERR, + todo_output => \*STDOUT + ); + + for my $method (keys %handles) { + my $src = $handles{$method}; + + my $dest = Test::More->builder->$method; + + is_deeply { map { $_ => 1 } PerlIO::get_layers($dest) }, + { map { $_ => 1 } PerlIO::get_layers($src) }, + "layers copied to $method"; + } +} + +SKIP: { + skip( "Can't test in general because their locale is unknown", 2 ) + unless $ENV{AUTHOR_TESTING}; + + my $uni = "\x{11e}"; + + my @warnings; + local $SIG{__WARN__} = sub { + push @warnings, @_; + }; + + is( $uni, $uni, "Testing $uni" ); + is_deeply( \@warnings, [] ); +} diff -urN perl-5.10.0.orig/lib/Test/Simple/t/versions.t perl-5.10.0/lib/Test/Simple/t/versions.t --- perl-5.10.0.orig/lib/Test/Simple/t/versions.t 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple/t/versions.t 2009-08-26 06:14:11.000000000 +0200 @@ -0,0 +1,21 @@ +#!/usr/bin/perl -w + +# Make sure all the modules have the same version +# +# TBT has its own version system. + +use strict; +use Test::More; + +require Test::Builder; +require Test::Builder::Module; +require Test::Simple; + +my $dist_version = $Test::More::VERSION; + +like( $dist_version, qr/^ \d+ \. \d+ $/x ); +is( $dist_version, $Test::Builder::VERSION, 'Test::Builder' ); +is( $dist_version, $Test::Builder::Module::VERSION, 'TB::Module' ); +is( $dist_version, $Test::Simple::VERSION, 'Test::Simple' ); + +done_testing(4); diff -urN perl-5.10.0.orig/lib/Test/Simple.pm perl-5.10.0/lib/Test/Simple.pm --- perl-5.10.0.orig/lib/Test/Simple.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/Test/Simple.pm 2009-08-26 06:14:11.000000000 +0200 @@ -2,18 +2,17 @@ use 5.004; -use strict 'vars'; -use vars qw($VERSION @ISA @EXPORT); -$VERSION = '0.72'; -$VERSION = eval $VERSION; # make the alpha version come out as a number +use strict; + +our $VERSION = '0.92'; +$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) use Test::Builder::Module; -@ISA = qw(Test::Builder::Module); -@EXPORT = qw(ok); +our @ISA = qw(Test::Builder::Module); +our @EXPORT = qw(ok); my $CLASS = __PACKAGE__; - =head1 NAME Test::Simple - Basic utilities for writing tests. @@ -77,11 +76,10 @@ =cut -sub ok ($;$) { - $CLASS->builder->ok(@_); +sub ok ($;$) { ## no critic (Subroutines::ProhibitSubroutinePrototypes) + return $CLASS->builder->ok(@_); } - =back Test::Simple will start by printing number of tests run in the form @@ -191,24 +189,10 @@ (i.e. you can just use Test::More instead of Test::Simple in your programs and things will still work). -=item L - -The original Perl testing module. - -=item L - -Elaborate unit testing. - -=item L, L - -Embed tests in your code! - -=item L - -Interprets the output of your test program. - =back +Look in Test::More's SEE ALSO for more testing modules. + =head1 AUTHORS @@ -218,7 +202,7 @@ =head1 COPYRIGHT -Copyright 2001, 2002, 2004 by Michael G Schwern Eschwern@pobox.comE. +Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff -urN perl-5.10.0.orig/MANIFEST perl-5.10.0/MANIFEST --- perl-5.10.0.orig/MANIFEST 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/MANIFEST 2009-08-26 06:14:11.000000000 +0200 @@ -2626,20 +2626,34 @@ lib/Test/Simple/Changes Test::Simple changes lib/Test/Simple.pm Basic utility for writing tests lib/Test/Simple/README Test::Simple README +lib/Test/Simple/TODO Test::Simple TODO lib/Test/Simple/t/00test_harness_check.t Test::Simple test lib/Test/Simple/t/bad_plan.t Test::Builder plan() test lib/Test/Simple/t/bail_out.t Test::Builder BAIL_OUT test +lib/Test/Simple/t/BEGIN_require_ok.t +lib/Test/Simple/t/BEGIN_use_ok.t lib/Test/Simple/t/buffer.t Test::Builder buffering test lib/Test/Simple/t/Builder.t Test::Builder tests +lib/Test/Simple/t/c_flag.t lib/Test/Simple/t/carp.t Test::Builder test lib/Test/Simple/t/circular_data.t Test::Simple test lib/Test/Simple/t/cmp_ok.t Test::More test lib/Test/Simple/t/create.t Test::Simple test -lib/Test/Simple/t/curr_test.t Test::Builder->curr_test tests +lib/Test/Simple/t/current_test.t +lib/Test/Simple/t/current_test_without_plan.t lib/Test/Simple/t/details.t Test::Builder tests lib/Test/Simple/t/diag.t Test::More diag() test +lib/Test/Simple/t/died.t +lib/Test/Simple/t/done_testing_double.t +lib/Test/Simple/t/done_testing_plan_mismatch.t +lib/Test/Simple/t/done_testing.t +lib/Test/Simple/t/done_testing_with_no_plan.t +lib/Test/Simple/t/done_testing_with_number.t +lib/Test/Simple/t/done_testing_with_plan.t +lib/Test/Simple/t/dont_overwrite_die_handler.t lib/Test/Simple/t/eq_set.t Test::Simple test lib/Test/Simple/t/exit.t Test::Simple test, exit codes +lib/Test/Simple/t/explain.t lib/Test/Simple/t/extra_one.t Test::Simple test lib/Test/Simple/t/extra.t Test::Simple test lib/Test/Simple/t/fail-like.t Test::More test, like() failures @@ -2648,6 +2662,7 @@ lib/Test/Simple/t/fail.t Test::Simple test, test failures lib/Test/Simple/t/filehandles.t Test::Simple test, STDOUT can be played with lib/Test/Simple/t/fork.t Test::More fork tests +lib/Test/Simple/t/fork_with_new_stdout.t lib/Test/Simple/t/harness_active.t Test::Simple test lib/Test/Simple/t/has_plan2.t Test::More->plan tests lib/Test/Simple/t/has_plan.t Test::Builder->plan tests @@ -2661,10 +2676,15 @@ lib/Test/Simple/t/maybe_regex.t Test::Builder->maybe_regex() tests lib/Test/Simple/t/missing.t Test::Simple test, missing tests lib/Test/Simple/t/More.t Test::More test, basic stuff +lib/Test/Simple/t/new_ok.t lib/Test/Simple/t/no_diag.t Test::Simple test lib/Test/Simple/t/no_ending.t Test::Builder test, no_ending() lib/Test/Simple/t/no_header.t Test::Builder test, no_header() lib/Test/Simple/t/no_plan.t Test::Simple test, forgot the plan +lib/Test/Simple/t/no_plan_at_all.t +lib/Test/Simple/t/no_tests.t +lib/Test/Simple/t/note.t +lib/Test/Simple/t/reset_outputs.t lib/Test/Simple/TODO Test::Simple TODO lib/Test/Simple/t/ok_obj.t Test::Builder object tests lib/Test/Simple/t/output.t Test::Builder test, output methods @@ -2681,6 +2701,7 @@ lib/Test/Simple/t/simple.t Test::Simple test, basic stuff lib/Test/Simple/t/skipall.t Test::More test, skip all tests lib/Test/Simple/t/skip.t Test::More test, SKIP tests +lib/Test/Simple/t/tbm_doesnt_set_exported_to.t lib/Test/Simple/t/tbt_01basic.t Test::Builder::Tester test lib/Test/Simple/t/tbt_02fhrestore.t Test::Builder::Tester test lib/Test/Simple/t/tbt_03die.t Test::Builder::Tester test @@ -2695,6 +2716,8 @@ lib/Test/Simple/t/undef.t Test::More test, undefs don't cause warnings lib/Test/Simple/t/useing.t Test::More test, compile test lib/Test/Simple/t/use_ok.t Test::More test, use_ok() +lib/Test/Simple/t/utf8.t +lib/Test/Simple/t/versions.t lib/Test/t/05_about_verbose.t See if Test works lib/Test/t/fail.t See if Test works lib/Test/t/mix.t See if Test works diff -urN perl-5.10.0.orig/t/lib/Test/Builder/NoOutput.pm perl-5.10.0/t/lib/Test/Builder/NoOutput.pm --- perl-5.10.0.orig/t/lib/Test/Builder/NoOutput.pm 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/t/lib/Test/Builder/NoOutput.pm 2009-08-26 06:14:11.000000000 +0200 @@ -0,0 +1,122 @@ +package Test::Builder::NoOutput; + +use strict; +use warnings; + +use base qw(Test::Builder); + + +=head1 NAME + +Test::Builder::NoOutput - A subclass of Test::Builder which prints nothing + +=head1 SYNOPSIS + + use Test::Builder::NoOutput; + + my $tb = Test::Builder::NoOutput->new; + + ...test as normal... + + my $output = $tb->read; + +=head1 DESCRIPTION + +This is a subclass of Test::Builder which traps all its output. +It is mostly useful for testing Test::Builder. + +=head3 read + + my $all_output = $tb->read; + my $output = $tb->read($stream); + +Returns all the output (including failure and todo output) collected +so far. It is destructive, each call to read clears the output +buffer. + +If $stream is given it will return just the output from that stream. +$stream's are... + + out output() + err failure_output() + todo todo_output() + all all outputs + +Defaults to 'all'. + +=cut + +my $Test = __PACKAGE__->new; + +sub create { + my $class = shift; + my $self = $class->SUPER::create(@_); + + my %outputs = ( + all => '', + out => '', + err => '', + todo => '', + ); + $self->{_outputs} = \%outputs; + + tie *OUT, "Test::Builder::NoOutput::Tee", \$outputs{all}, \$outputs{out}; + tie *ERR, "Test::Builder::NoOutput::Tee", \$outputs{all}, \$outputs{err}; + tie *TODO, "Test::Builder::NoOutput::Tee", \$outputs{all}, \$outputs{todo}; + + $self->output(*OUT); + $self->failure_output(*ERR); + $self->todo_output(*TODO); + + return $self; +} + +sub read { + my $self = shift; + my $stream = @_ ? shift : 'all'; + + my $out = $self->{_outputs}{$stream}; + + $self->{_outputs}{$stream} = ''; + + # Clear all the streams if 'all' is read. + if( $stream eq 'all' ) { + my @keys = keys %{$self->{_outputs}}; + $self->{_outputs}{$_} = '' for @keys; + } + + return $out; +} + + +package Test::Builder::NoOutput::Tee; + +# A cheap implementation of IO::Tee. + +sub TIEHANDLE { + my($class, @refs) = @_; + + my @fhs; + for my $ref (@refs) { + my $fh = Test::Builder->_new_fh($ref); + push @fhs, $fh; + } + + my $self = [@fhs]; + return bless $self, $class; +} + +sub PRINT { + my $self = shift; + + print $_ @_ for @$self; +} + +sub PRINTF { + my $self = shift; + my $format = shift; + + printf $_ @_ for @$self; +} + +1; diff -urN perl-5.10.0.orig/t/lib/Test/Simple/Catch.pm perl-5.10.0/t/lib/Test/Simple/Catch.pm --- perl-5.10.0.orig/t/lib/Test/Simple/Catch.pm 2007-12-18 11:47:08.000000000 +0100 +++ perl-5.10.0/t/lib/Test/Simple/Catch.pm 2009-08-26 06:14:11.000000000 +0200 @@ -1,9 +1,11 @@ # For testing Test::Simple; package Test::Simple::Catch; +use strict; + use Symbol; use TieOut; -my($out_fh, $err_fh) = (gensym, gensym); +my( $out_fh, $err_fh ) = ( gensym, gensym ); my $out = tie *$out_fh, 'TieOut'; my $err = tie *$err_fh, 'TieOut'; @@ -13,6 +15,6 @@ $t->failure_output($err_fh); $t->todo_output($err_fh); -sub caught { return($out, $err) } +sub caught { return( $out, $err ) } 1; diff -urN perl-5.10.0.orig/t/lib/Test/Simple/sample_tests/death.plx perl-5.10.0/t/lib/Test/Simple/sample_tests/death.plx --- perl-5.10.0.orig/t/lib/Test/Simple/sample_tests/death.plx 2007-12-18 11:47:08.000000000 +0100 +++ perl-5.10.0/t/lib/Test/Simple/sample_tests/death.plx 2009-08-26 06:14:11.000000000 +0200 @@ -4,10 +4,13 @@ require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); +require Dev::Null; + Test::Simple->import(tests => 5); -close STDERR; +tie *STDERR, 'Dev::Null'; ok(1); ok(1); ok(1); -die "Knife?"; +$! = 0; +die "This is a test"; diff -urN perl-5.10.0.orig/t/lib/Test/Simple/sample_tests/death_with_handler.plx perl-5.10.0/t/lib/Test/Simple/sample_tests/death_with_handler.plx --- perl-5.10.0.orig/t/lib/Test/Simple/sample_tests/death_with_handler.plx 1970-01-01 01:00:00.000000000 +0100 +++ perl-5.10.0/t/lib/Test/Simple/sample_tests/death_with_handler.plx 2009-08-26 06:14:11.000000000 +0200 @@ -0,0 +1,20 @@ +require Test::Simple; + +push @INC, 't/lib'; +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); + +Test::Simple->import(tests => 2); + +# Test we still get the right exit code despite having a die +# handler. +$SIG{__DIE__} = sub {}; + +require Dev::Null; +tie *STDERR, 'Dev::Null'; + +ok(1); +ok(1); + +$! = 0; +die "This is a test"; diff -urN perl-5.10.0.orig/t/lib/Test/Simple/sample_tests/last_minute_death.plx perl-5.10.0/t/lib/Test/Simple/sample_tests/last_minute_death.plx --- perl-5.10.0.orig/t/lib/Test/Simple/sample_tests/last_minute_death.plx 2007-12-18 11:47:08.000000000 +0100 +++ perl-5.10.0/t/lib/Test/Simple/sample_tests/last_minute_death.plx 2009-08-26 06:14:11.000000000 +0200 @@ -5,7 +5,9 @@ my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import(tests => 5); -close STDERR; + +require Dev::Null; +tie *STDERR, 'Dev::Null'; ok(1); ok(1); @@ -13,4 +15,5 @@ ok(1); ok(1); -die "Almost there..."; +$! = 0; +die "This is a test"; diff -urN perl-5.10.0.orig/t/lib/Test/Simple/sample_tests/too_few_fail.plx perl-5.10.0/t/lib/Test/Simple/sample_tests/too_few_fail.plx --- perl-5.10.0.orig/t/lib/Test/Simple/sample_tests/too_few_fail.plx 2007-12-18 11:47:08.000000000 +0100 +++ perl-5.10.0/t/lib/Test/Simple/sample_tests/too_few_fail.plx 2009-08-26 06:14:11.000000000 +0200 @@ -9,4 +9,4 @@ ok(0); ok(1); -ok(0); \ No newline at end of file +ok(0); diff -urN perl-5.10.0.orig/t/lib/TieOut.pm perl-5.10.0/t/lib/TieOut.pm --- perl-5.10.0.orig/t/lib/TieOut.pm 2007-12-18 11:47:08.000000000 +0100 +++ perl-5.10.0/t/lib/TieOut.pm 2009-08-26 06:14:11.000000000 +0200 @@ -1,13 +1,15 @@ package TieOut; +use strict; + sub TIEHANDLE { my $scalar = ''; - bless( \$scalar, $_[0]); + bless( \$scalar, $_[0] ); } sub PRINT { my $self = shift; - $$self .= join('', @_); + $$self .= join( '', @_ ); } sub PRINTF { @@ -16,7 +18,7 @@ $$self .= sprintf $fmt, @_; } -sub FILENO {} +sub FILENO { } sub read { my $self = shift;