From: Steve Peters Date: Fri, 29 Feb 2008 04:39:18 +0000 (+0000) Subject: Upgrade to Test-Simple-0.78 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=04955c1432b0be1ddb216b8c8dce2058e6337802;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Test-Simple-0.78 p4raw-id: //depot/perl@33394 --- diff --git a/MANIFEST b/MANIFEST index 55db224..44df5db 100644 --- a/MANIFEST +++ b/MANIFEST @@ -2708,6 +2708,7 @@ 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/details.t Test::Builder tests lib/Test/Simple/t/diag.t Test::More diag() test +lib/Test/Simple/t/dont_overwrite_die_handler.t Test::More tests 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/extra_one.t Test::Simple test @@ -2751,6 +2752,7 @@ lib/Test/Simple/t/reset.t Test::Simple test 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 Test::Builder::Module test 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 @@ -2765,6 +2767,7 @@ lib/Test/Simple/t/try.t Test::More test 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 Test::More test 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 @@ -3665,6 +3668,7 @@ t/lib/strict/subs Tests of "use strict 'subs'" for strict.t t/lib/strict/vars Tests of "use strict 'vars'" for strict.t t/lib/Test/Simple/Catch.pm Utility module for testing Test::Simple t/lib/Test/Simple/sample_tests/death_in_eval.plx for exit.t +t/lib/Test/Simple/sample_tests/death_with_handler.plx for exit.t t/lib/Test/Simple/sample_tests/death.plx for exit.t t/lib/Test/Simple/sample_tests/exit.plx for exit.t t/lib/Test/Simple/sample_tests/extras.plx for exit.t diff --git a/lib/Test/Builder.pm b/lib/Test/Builder.pm index b2bb376..57a57d2 100644 --- a/lib/Test/Builder.pm +++ b/lib/Test/Builder.pm @@ -73,28 +73,15 @@ Test::Builder - Backend for building test libraries =head1 SYNOPSIS package My::Test::Module; - use Test::Builder; - require Exporter; - @ISA = qw(Exporter); - @EXPORT = qw(ok); + use base 'Test::Builder::Module'; - my $Test = Test::Builder->new; - $Test->output('my_logfile'); - - sub import { - my($self) = shift; - my $pack = caller; - - $Test->exported_to($pack); - $Test->plan(@_); - - $self->export_to_level(1, $self, 'ok'); - } + my $CLASS = __PACKAGE__; sub ok { my($test, $name) = @_; + my $tb = $CLASS->builder; - $Test->ok($test, $name); + $tb->ok($test, $name); } @@ -177,7 +164,6 @@ sub reset { # hash keys is just asking for pain. Also, it was documented. $Level = 1; - $self->{Test_Died} = 0; $self->{Have_Plan} = 0; $self->{No_Plan} = 0; $self->{Original_Pid} = $$; @@ -196,6 +182,8 @@ sub reset { $self->{No_Header} = 0; $self->{No_Ending} = 0; + $self->{TODO} = undef; + $self->_dup_stdhandles unless $^C; return; @@ -210,25 +198,6 @@ are. You usually only want to call one of these methods. =over 4 -=item B - - my $pack = $Test->exported_to; - $Test->exported_to($pack); - -Tells Test::Builder what package you exported your functions to. -This is important for getting TODO tests right. - -=cut - -sub exported_to { - my($self, $pack) = @_; - - if( defined $pack ) { - $self->{Exported_To} = $pack; - } - return $self->{Exported_To}; -} - =item B $Test->plan('no_plan'); @@ -360,6 +329,29 @@ sub skip_all { 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 @@ -402,6 +394,11 @@ sub ok { ERR my $todo = $self->todo(); + + # Capture the value of $TODO for the rest of this ok() call + # so it can more easily be found by other routines. + local $self->{TODO} = $todo; + $self->_unoverload_str(\$todo); my $out; @@ -583,6 +580,7 @@ sub _is_diag { } } + local $Level = $Level + 1; return $self->diag(sprintf <diag(sprintf <diag(sprintf <output(\*TESTOUT); - $self->failure_output(\*TESTERR); - $self->todo_output(\*TESTOUT); + $self->output ($Testout); + $self->failure_output($Testerr); + $self->todo_output ($Testout); } my $Opened_Testhandles = 0; sub _open_testhandles { + my $self = shift; + return if $Opened_Testhandles; + # We dup STDOUT and STDERR so people can change them in their # test suites while still getting normal test output. - open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!"; - open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!"; + open( $Testout, ">&STDOUT") or die "Can't dup STDOUT: $!"; + open( $Testerr, ">&STDERR") or die "Can't dup STDERR: $!"; + +# $self->_copy_io_layers( \*STDOUT, $Testout ); +# $self->_copy_io_layers( \*STDERR, $Testerr ); + $Opened_Testhandles = 1; } +sub _copy_io_layers { + my($self, $src, $dest) = @_; + + $self->_try(sub { + require PerlIO; + my @layers = PerlIO::get_layers($src); + + binmode $dest, join " ", map ":$_", @layers if @layers; + }); +} + =item carp $tb->carp(@message); @@ -1562,9 +1594,10 @@ will be considered 'todo' (see Test::More and Test::Harness for details). Returns the reason (ie. the value of $TODO) if running as todo tests, false otherwise. -todo() is 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. +todo() is about finding the right package to look for $TODO in. It's +pretty good at guessing the right package to look at. It first looks for +the caller based on C<$Level + 1>, since C is usually called inside +a test function. As a last resort it will use C. Sometimes there is some confusion about where todo() should be looking for the $TODO variable. If you want to be sure, tell it explicitly @@ -1575,7 +1608,9 @@ what $pack to use. sub todo { my($self, $pack) = @_; - $pack = $pack || $self->exported_to || $self->caller($Level); + return $self->{TODO} if defined $self->{TODO}; + + $pack = $pack || $self->caller(1) || $self->exported_to; return 0 unless $pack; no strict 'refs'; ## no critic @@ -1591,6 +1626,8 @@ sub todo { Like the normal caller(), except it reports according to your level(). +C<$height> will be added to the level(). + =cut sub caller { @@ -1675,35 +1712,27 @@ sub _my_exit { =cut -$SIG{__DIE__} = sub { - # We don't want to muck with death in an eval, but $^S isn't - # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing - # with it. Instead, we use caller. This also means it runs under - # 5.004! - my $in_eval = 0; - for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) { - $in_eval = 1 if $sub =~ /^\(eval\)/; - } - $Test->{Test_Died} = 1 unless $in_eval; -}; - sub _ending { my $self = shift; + my $real_exit_code = $?; $self->_sanity_check(); # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. + if( $self->{Original_Pid} != $$ ) { + return; + } + # Exit if plan() was never called. This is so "require Test::Simple" # 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. @@ -1753,7 +1782,7 @@ Looks like you failed $num_failed test$s of $num_tests$qualifier. FAIL } - if( $self->{Test_Died} ) { + if( $real_exit_code ) { $self->diag(<<"FAIL"); Looks like your test died just after $self->{Curr_Test}. FAIL @@ -1777,7 +1806,7 @@ FAIL elsif ( $self->{Skip_All} ) { _my_exit( 0 ) && return; } - elsif ( $self->{Test_Died} ) { + elsif ( $real_exit_code ) { $self->diag(<<'FAIL'); Looks like your test died before it could output anything. FAIL diff --git a/lib/Test/Builder/Module.pm b/lib/Test/Builder/Module.pm index 82d19c6..514c405 100644 --- a/lib/Test/Builder/Module.pm +++ b/lib/Test/Builder/Module.pm @@ -7,7 +7,7 @@ use Test::Builder; require Exporter; our @ISA = qw(Exporter); -our $VERSION = '0.75'; +our $VERSION = '0.78'; # 5.004's Exporter doesn't have export_to_level. my $_export_to_level = sub { @@ -83,6 +83,9 @@ import_extra(). 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; diff --git a/lib/Test/Builder/Tester.pm b/lib/Test/Builder/Tester.pm index ef66d66..fdb3fb1 100644 --- a/lib/Test/Builder/Tester.pm +++ b/lib/Test/Builder/Tester.pm @@ -1,7 +1,7 @@ package Test::Builder::Tester; use strict; -our $VERSION = "1.12"; +our $VERSION = "1.13"; use Test::Builder; use Symbol; diff --git a/lib/Test/More.pm b/lib/Test/More.pm index a33be4c..e5a0a93 100644 --- a/lib/Test/More.pm +++ b/lib/Test/More.pm @@ -15,7 +15,7 @@ sub _carp { use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); -$VERSION = '0.75'; +$VERSION = '0.78'; $VERSION = eval $VERSION; # make the alpha version come out as a number use Test::Builder::Module; @@ -30,7 +30,7 @@ use Test::Builder::Module; plan can_ok isa_ok diag - BAIL_OUT + BAIL_OUT ); diff --git a/lib/Test/Simple.pm b/lib/Test/Simple.pm index a070133..120893d 100644 --- a/lib/Test/Simple.pm +++ b/lib/Test/Simple.pm @@ -4,7 +4,7 @@ use 5.004; use strict 'vars'; use vars qw($VERSION @ISA @EXPORT); -$VERSION = '0.75'; +$VERSION = '0.78'; $VERSION = eval $VERSION; # make the alpha version come out as a number use Test::Builder::Module; diff --git a/lib/Test/Simple/t/dont_overwrite_die_handler.t b/lib/Test/Simple/t/dont_overwrite_die_handler.t new file mode 100644 index 0000000..0657a06 --- /dev/null +++ b/lib/Test/Simple/t/dont_overwrite_die_handler.t @@ -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 --git a/lib/Test/Simple/t/exit.t b/lib/Test/Simple/t/exit.t index 6630b64..e85e460 100644 --- a/lib/Test/Simple/t/exit.t +++ b/lib/Test/Simple/t/exit.t @@ -25,18 +25,9 @@ if( $^O eq 'MacOS' ) { 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; @@ -59,10 +50,11 @@ my %Tests = ( 'pre_plan_death.plx' => ['not zero', 'not zero'], 'death_in_eval.plx' => [0, 0], 'require.plx' => [0, 0], - 'exit.plx' => [1, 4], + 'death_with_handler.plx' => [255, 4], + 'exit.plx' => [1, 4], ); -print "1..".keys(%Tests)."\n"; +$TB->plan( tests => scalar keys(%Tests) ); eval { require POSIX; &POSIX::WEXITSTATUS(0) }; if( $@ ) { @@ -93,12 +85,12 @@ while( my($test_name, $exit_codes) = each %Tests ) { my $actual_exit = exitstatus($wait_stat); if( $exit_code eq 'not zero' ) { - My::Test::ok( $actual_exit != 0, + $TB->isnt_num( $actual_exit, 0, "$test_name exited with $actual_exit ". "(expected $exit_code)"); } else { - My::Test::ok( $actual_exit == $exit_code, + $TB->is_num( $actual_exit, $exit_code, "$test_name exited with $actual_exit ". "(expected $exit_code)"); } diff --git a/lib/Test/Simple/t/filehandles.t b/lib/Test/Simple/t/filehandles.t index dfea4ba..fed9e1e 100644 --- a/lib/Test/Simple/t/filehandles.t +++ b/lib/Test/Simple/t/filehandles.t @@ -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 --git a/lib/Test/Simple/t/is_deeply_with_threads.t b/lib/Test/Simple/t/is_deeply_with_threads.t index cf6b6ba..e7867a5 100644 --- a/lib/Test/Simple/t/is_deeply_with_threads.t +++ b/lib/Test/Simple/t/is_deeply_with_threads.t @@ -24,7 +24,7 @@ BEGIN { } unless ( $ENV{AUTHOR_TESTING} ) { - print "1..0 # Skip: many perls have broken threads\n"; + print "1..0 # Skip: many perls have broken threads. Enable with AUTHOR_TESTING.\n"; exit 0; } } diff --git a/lib/Test/Simple/t/maybe_regex.t b/lib/Test/Simple/t/maybe_regex.t index e4d7506..d1927a5 100644 --- a/lib/Test/Simple/t/maybe_regex.t +++ b/lib/Test/Simple/t/maybe_regex.t @@ -11,22 +11,24 @@ BEGIN { } use strict; -use Test::More tests => 13; +use Test::More tests => 16; use Test::Builder; my $Test = Test::Builder->new; +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'); + SKIP: { - skip "qr// added in 5.005", 3 if $] < 5.005; - - # 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 "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 --git a/lib/Test/Simple/t/reset.t b/lib/Test/Simple/t/reset.t index 320fd86..5a7b07f 100644 --- a/lib/Test/Simple/t/reset.t +++ b/lib/Test/Simple/t/reset.t @@ -16,6 +16,11 @@ chdir 't'; use Test::Builder; my $tb = Test::Builder->new; + +my %Original_Output; +$Original_Output{$_} = $tb->$_ for qw(output failure_output todo_output); + + $tb->plan(tests => 14); $tb->level(0); @@ -66,11 +71,11 @@ 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, +ok( fileno $tb->output == fileno $Original_Output{output}, 'output' ); -ok( fileno $tb->failure_output == fileno *Test::Builder::TESTERR, +ok( fileno $tb->failure_output == fileno $Original_Output{failure_output}, 'failure_output' ); -ok( fileno $tb->todo_output == fileno *Test::Builder::TESTOUT, +ok( fileno $tb->todo_output == fileno $Original_Output{todo_output}, 'todo_output' ); ok( $tb->current_test == 0, 'current_test' ); ok( $tb->summary == 0, 'summary' ); diff --git a/lib/Test/Simple/t/tbm_doesnt_set_exported_to.t b/lib/Test/Simple/t/tbm_doesnt_set_exported_to.t new file mode 100644 index 0000000..f5ad001 --- /dev/null +++ b/lib/Test/Simple/t/tbm_doesnt_set_exported_to.t @@ -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()' +); \ No newline at end of file diff --git a/lib/Test/Simple/t/todo.t b/lib/Test/Simple/t/todo.t index 6ea51a6..d589c92 100644 --- a/lib/Test/Simple/t/todo.t +++ b/lib/Test/Simple/t/todo.t @@ -69,21 +69,20 @@ TODO: { # perl gets the line number a little wrong on the first # statement inside a block. 1 == 1; -#line 82 +#line 73 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 73\n", 'todo_skip without $how_many warning' ); } -{ +TODO: { Test::More->builder->exported_to("Wibble"); - $Wibble::TODO = ''; # shut up used only once warning - TODO: { - local $Wibble::TODO = $Why; - fail("TODO honors exported_to()"); - } -} \ No newline at end of file + + local $TODO = "testing \$TODO with an incorrect exported_to()"; + + fail("Just testing todo"); +} diff --git a/lib/Test/Simple/t/utf8.t b/lib/Test/Simple/t/utf8.t new file mode 100644 index 0000000..7640db6 --- /dev/null +++ b/lib/Test/Simple/t/utf8.t @@ -0,0 +1,61 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } +} + +use strict; +use warnings; + + +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 tests => 5; +use Test::More skip_all => 'Not yet implemented'; + +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 [PerlIO::get_layers($dest)], + [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, [] ); +} \ No newline at end of file diff --git a/t/lib/Test/Simple/sample_tests/death.plx b/t/lib/Test/Simple/sample_tests/death.plx index ef4ba8c..493784c 100644 --- a/t/lib/Test/Simple/sample_tests/death.plx +++ b/t/lib/Test/Simple/sample_tests/death.plx @@ -4,10 +4,12 @@ push @INC, 't/lib'; 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?"; +die "This is a test"; diff --git a/t/lib/Test/Simple/sample_tests/death_with_handler.plx b/t/lib/Test/Simple/sample_tests/death_with_handler.plx new file mode 100644 index 0000000..2009a0e --- /dev/null +++ b/t/lib/Test/Simple/sample_tests/death_with_handler.plx @@ -0,0 +1,18 @@ +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); +die "This is a test"; diff --git a/t/lib/Test/Simple/sample_tests/last_minute_death.plx b/t/lib/Test/Simple/sample_tests/last_minute_death.plx index ef86a63..fe8451e 100644 --- a/t/lib/Test/Simple/sample_tests/last_minute_death.plx +++ b/t/lib/Test/Simple/sample_tests/last_minute_death.plx @@ -5,7 +5,9 @@ require Test::Simple::Catch; 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,4 @@ ok(1); ok(1); ok(1); -die "Almost there..."; +die "This is a test";