From: Rafael Garcia-Suarez Date: Wed, 15 Dec 2004 13:16:06 +0000 (+0000) Subject: Upgrade to Test::Simple 0.54 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0257f296204adb69c838f5fbb883eb20cd264593;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Test::Simple 0.54 p4raw-id: //depot/perl@23654 --- diff --git a/MANIFEST b/MANIFEST index 2056fc8..3d96603 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1805,6 +1805,7 @@ lib/Test/Simple/t/has_plan2.t Test::More->plan tests lib/Test/Simple/t/has_plan.t Test::Builder->plan tests lib/Test/Simple/t/import.t Test::More test, importing functions lib/Test/Simple/t/is_deeply.t Test::More test, is_deeply() +lib/Test/Simple/t/is_fh.t Test::Builder test, _is_fh() 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 diff --git a/lib/Test/Builder.pm b/lib/Test/Builder.pm index 54bd199..9f6a3a4 100644 --- a/lib/Test/Builder.pm +++ b/lib/Test/Builder.pm @@ -8,7 +8,7 @@ $^C ||= 0; use strict; use vars qw($VERSION); -$VERSION = '0.21'; +$VERSION = '0.22'; $VERSION = eval $VERSION; # make the alpha version come out as a number # Make Test::Builder thread-safe for ithreads. @@ -145,7 +145,6 @@ my $Curr_Test; share($Curr_Test); use vars qw($Level); my $Original_Pid; my @Test_Results; share(@Test_Results); -my @Test_Details; share(@Test_Details); my $Exported_To; my $Expected_Tests; @@ -168,7 +167,6 @@ sub reset { $Level = 1; $Original_Pid = $$; @Test_Results = (); - @Test_Details = (); $Exported_To = undef; $Expected_Tests = 0; @@ -639,16 +637,26 @@ could be written as: sub maybe_regex { - my ($self, $regex) = @_; + my ($self, $regex) = @_; my $usable_regex = undef; + + return $usable_regex unless defined $regex; + + my($re, $opts); + + # Check for qr/foo/ if( ref $regex eq 'Regexp' ) { $usable_regex = $regex; } - # Check if it looks like '/foo/' - elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) { + # Check for '/foo/' or 'm,foo,' + elsif( ($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or + (undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx + ) + { $usable_regex = length $opts ? "(?$opts)$re" : $re; - }; - return($usable_regex) + } + + return $usable_regex; }; sub _regex_ok { @@ -781,7 +789,9 @@ sub skip { my $out = "ok"; $out .= " $Curr_Test" if $self->use_numbers; - $out .= " # skip $why\n"; + $out .= " # skip"; + $out .= " $why" if length $why; + $out .= "\n"; $Test->_print($out); @@ -1120,22 +1130,37 @@ sub todo_output { return $Todo_FH; } + sub _new_fh { my($file_or_fh) = shift; my $fh; - unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) { + if( _is_fh($file_or_fh) ) { + $fh = $file_or_fh; + } + else { $fh = do { local *FH }; open $fh, ">$file_or_fh" or die "Can't open test output log $file_or_fh: $!"; } - else { - $fh = $file_or_fh; - } return $fh; } + +sub _is_fh { + my $maybe_fh = shift; + + return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob + + return UNIVERSAL::isa($maybe_fh, 'GLOB') || + UNIVERSAL::isa($maybe_fh, 'IO::Handle') || + + # 5.5.4's tied() and can() doesn't like getting undef + UNIVERSAL::can((tied($maybe_fh) || ''), 'TIEHANDLE'); +} + + sub _autoflush { my($fh) = shift; my $old_fh = select $fh; @@ -1183,9 +1208,12 @@ sub _open_testhandles { my $curr_test = $Test->current_test; $Test->current_test($num); -Gets/sets the current test # we're on. +Gets/sets the current test number we're on. You usually shouldn't +have to set this. -You usually shouldn't have to set this. +If set forward, the details of the missing tests are filled in as 'unknown'. +if set backward, the details of the intervening tests are deleted. You +can erase history if you really want to. =cut @@ -1200,6 +1228,8 @@ sub current_test { } $Curr_Test = $num; + + # If the test counter is being pushed forward fill in the details. if( $num > @Test_Results ) { my $start = @Test_Results ? $#Test_Results + 1 : 0; for ($start..$num-1) { @@ -1212,6 +1242,10 @@ sub current_test { }); } } + # If backward, wipe history. Its their funeral. + elsif( $num < @Test_Results ) { + $#Test_Results = $num - 1; + } } return $Curr_Test; } diff --git a/lib/Test/More.pm b/lib/Test/More.pm index 8f029e6..aa02808 100644 --- a/lib/Test/More.pm +++ b/lib/Test/More.pm @@ -18,7 +18,7 @@ sub _carp { require Exporter; use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); -$VERSION = '0.53'; +$VERSION = '0.54'; $VERSION = eval $VERSION; # make the alpha version come out as a number @ISA = qw(Exporter); @@ -855,8 +855,10 @@ the easiest way to illustrate: If the user does not have HTML::Lint installed, the whole block of code I. Test::More will output special ok's which Test::Harness interprets as skipped, but passing, tests. + It's important that $how_many accurately reflects the number of tests in the SKIP block so the # of tests run will match up with your plan. +If your plan is C $how_many is optional and will default to 1. It's perfectly safe to nest SKIP blocks. Each SKIP block must have the label C, or Test::More can't work its magic. @@ -874,7 +876,7 @@ sub skip { unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "skip() needs to know \$how_many tests are in the block" - unless $Test::Builder::No_Plan; + unless $Test->has_plan eq 'no_plan'; $how_many = 1; } @@ -954,7 +956,7 @@ sub todo_skip { unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "todo_skip() needs to know \$how_many tests are in the block" - unless $Test::Builder::No_Plan; + unless $Test->has_plan eq 'no_plan'; $how_many = 1; } @@ -1084,6 +1086,19 @@ sub _format_stack { } +sub _type { + my $thing = shift; + + return '' if !ref $thing; + + for my $type (qw(ARRAY HASH REF SCALAR GLOB Regexp)) { + return $type if UNIVERSAL::isa($thing, $type); + } + + return ''; +} + + =item B eq_array(\@this, \@that); @@ -1103,7 +1118,7 @@ sub eq_array { sub _eq_array { my($a1, $a2) = @_; - if( grep !UNIVERSAL::isa($_, 'ARRAY'), $a1, $a2 ) { + if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) { warn "eq_array passed a non-array ref"; return 0; } @@ -1156,34 +1171,29 @@ sub _deep_check { $ok = 1; } else { - if( UNIVERSAL::isa($e1, 'ARRAY') and - UNIVERSAL::isa($e2, 'ARRAY') ) - { + my $type = _type($e1); + $type = '' unless _type($e2) eq $type; + + if( !$type ) { + push @Data_Stack, { vals => [$e1, $e2] }; + $ok = 0; + } + elsif( $type eq 'ARRAY' ) { $ok = _eq_array($e1, $e2); } - elsif( UNIVERSAL::isa($e1, 'HASH') and - UNIVERSAL::isa($e2, 'HASH') ) - { + elsif( $type eq 'HASH' ) { $ok = _eq_hash($e1, $e2); } - elsif( UNIVERSAL::isa($e1, 'REF') and - UNIVERSAL::isa($e2, 'REF') ) - { + elsif( $type eq 'REF' ) { push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; $ok = _deep_check($$e1, $$e2); pop @Data_Stack if $ok; } - elsif( UNIVERSAL::isa($e1, 'SCALAR') and - UNIVERSAL::isa($e2, 'SCALAR') ) - { + elsif( $type eq 'SCALAR' ) { push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; $ok = _deep_check($$e1, $$e2); pop @Data_Stack if $ok; } - else { - push @Data_Stack, { vals => [$e1, $e2] }; - $ok = 0; - } } } @@ -1209,7 +1219,7 @@ sub eq_hash { sub _eq_hash { my($a1, $a2) = @_; - if( grep !UNIVERSAL::isa($_, 'HASH'), $a1, $a2 ) { + if( grep !_type($_) eq 'HASH', $a1, $a2 ) { warn "eq_hash passed a non-hash ref"; return 0; } diff --git a/lib/Test/Simple.pm b/lib/Test/Simple.pm index ea3f119..05b4dd5 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); -$VERSION = '0.53'; +$VERSION = '0.54'; $VERSION = eval $VERSION; # make the alpha version come out as a number diff --git a/lib/Test/Simple/Changes b/lib/Test/Simple/Changes index 083d97f..f9e6483 100644 --- a/lib/Test/Simple/Changes +++ b/lib/Test/Simple/Changes @@ -1,3 +1,18 @@ +0.54 Wed Dec 15 04:18:43 EST 2004 + * $how_many is optional for skip() and todo_skip(). Thanks to + Devel::Cover for pointing this out. + - Removed a user defined function called err() in the tests to placate + users of older versions of the dor patch before err() was weakend. + [rt.cpan.org 8734] + +0.53_01 Sat Dec 11 19:02:18 EST 2004 + - current_test() can now be set backward. + - *output() methods now handle tied handles and *FOO{IO} properly. + - maybe_regex() now handles undef gracefully. + - maybe_regex() now handles 'm,foo,' style regexes. + - sort_bug.t wasn't checking for threads properly. Would fail on + 5.6 that had ithreads compiled in. [rt.cpan.org 8765] + 0.53 Mon Nov 29 04:43:24 EST 2004 - Apparently its possible to have Module::Signature installed without it being functional. Fixed the signature test to account for this. diff --git a/lib/Test/Simple/t/details.t b/lib/Test/Simple/t/details.t index 65dcf8d..bd0ea9b 100644 --- a/lib/Test/Simple/t/details.t +++ b/lib/Test/Simple/t/details.t @@ -14,7 +14,7 @@ use Test::More; use Test::Builder; my $Test = Test::Builder->new; -$Test->plan( tests => 8 ); +$Test->plan( tests => 9 ); $Test->level(0); my @Expected_Details; @@ -29,11 +29,13 @@ push @Expected_Details, { 'ok' => 1, # 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 $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); SKIP: { $Test->skip( 'just testing skip' ); @@ -67,6 +69,7 @@ push @Expected_Details, { 'ok' => 1, for ($start_test..$Test->current_test) { print "ok $_\n" } $Test->output($out_fh); +$Test->todo_output($todo_fh); $Test->is_num( scalar $Test->summary(), 4, 'summary' ); push @Expected_Details, { 'ok' => 1, @@ -91,3 +94,14 @@ $Test->is_num( scalar @details, 6, $Test->level(1); is_deeply( \@details, \@Expected_Details ); + + +# This test has to come last because it thrashes the test details. +{ + my $curr_test = $Test->current_test; + $Test->current_test(4); + my @details = $Test->details(); + + $Test->current_test($curr_test); + $Test->is_num( scalar @details, 4 ); +} diff --git a/lib/Test/Simple/t/fail-more.t b/lib/Test/Simple/t/fail-more.t index ab18b5b..2086df2 100644 --- a/lib/Test/Simple/t/fail-more.t +++ b/lib/Test/Simple/t/fail-more.t @@ -38,7 +38,7 @@ sub ok ($;$) { } -sub main::err ($) { +sub main::err_ok ($) { my($expect) = @_; my $got = $err->read; @@ -65,7 +65,7 @@ $tb->use_numbers(0); # Preserve the line numbers. #line 38 ok( 0, 'failing' ); -err( <can('this') failed # Mooble::Hooble::Yooble->can('that') failed @@ -149,7 +149,7 @@ isa_ok(bless([], "Foo"), "Wibble"); isa_ok(42, "Wibble", "My Wibble"); isa_ok(undef, "Wibble", "Another Wibble"); isa_ok([], "HASH"); -err( <read; @@ -63,13 +63,13 @@ Test::More->builder->no_ending(1); #line 62 fail( "this fails" ); - err( <[1] = 'b' # \$expected->[1] = 'c' ERR + + +#line 285 +my $ref = \23; +is_deeply( 23, $ref ); +is( $out, "not ok 21\n", 'scalar vs ref' ); +is( $err, < 6; +use TieOut; + +ok( !Test::Builder::_is_fh("foo"), 'string is not a filehandle' ); + +ok( open(FILE, '>foo') ); +END { unlink 'foo' } + +ok( Test::Builder::_is_fh(*FILE) ); +ok( Test::Builder::_is_fh(\*FILE) ); +ok( Test::Builder::_is_fh(*FILE{IO}) ); + +tie *OUT, 'TieOut'; +ok( Test::Builder::_is_fh(*OUT) ); \ No newline at end of file diff --git a/lib/Test/Simple/t/maybe_regex.t b/lib/Test/Simple/t/maybe_regex.t index dcc84f4..e4d7506 100644 --- a/lib/Test/Simple/t/maybe_regex.t +++ b/lib/Test/Simple/t/maybe_regex.t @@ -11,7 +11,7 @@ BEGIN { } use strict; -use Test::More tests => 10; +use Test::More tests => 13; use Test::Builder; my $Test = Test::Builder->new; @@ -48,3 +48,11 @@ SKIP: { ok(('f00' =~ m/$r/), '"//" good match'); ok(('b4r' !~ m/$r/), '"//" bad match'); }; + + +{ + my $r = $Test->maybe_regex('m,foo,i'); + ok(defined $r, 'm,, detected'); + ok(('fOO' =~ m/$r/), '"//" good match'); + ok(('bar' !~ m/$r/), '"//" bad match'); +}; diff --git a/lib/Test/Simple/t/plan_no_plan.t b/lib/Test/Simple/t/plan_no_plan.t index 6ae06bf..8c4492a 100644 --- a/lib/Test/Simple/t/plan_no_plan.t +++ b/lib/Test/Simple/t/plan_no_plan.t @@ -29,3 +29,24 @@ plan 'no_plan'; pass('Just testing'); ok(1, 'Testing again'); + +{ + my $warning = ''; + local $SIG{__WARN__} = sub { $warning = join "", @_ }; + SKIP: { + skip 'Just testing skip with no_plan'; + fail("So very failed"); + } + is( $warning, '', 'skip with no "how_many" ok with no_plan' ); + + + $warning = ''; + TODO: { + todo_skip "Just testing todo_skip"; + + fail("Just testing todo"); + die "todo_skip should prevent this"; + pass("Again"); + } + is( $warning, '', 'skip with no "how_many" ok with no_plan' ); +} diff --git a/lib/Test/Simple/t/sort_bug.t b/lib/Test/Simple/t/sort_bug.t index f99212a..aad806c 100644 --- a/lib/Test/Simple/t/sort_bug.t +++ b/lib/Test/Simple/t/sort_bug.t @@ -17,21 +17,21 @@ use strict; use Config; BEGIN { - require threads if $Config{useithreads}; + unless ( $] >= 5.008 && $Config{'useithreads'} && + eval { require threads; 'threads'->import; 1; }) + { + print "1..0 # Skip: no threads\n"; + exit 0; + } } use Test::More; # Passes with $nthreads = 1 and with eq_set(). # Passes with $nthreads = 2 and with eq_array(). # Fails with $nthreads = 2 and with eq_set(). -my $nthreads = 2; +my $Num_Threads = 2; -if( $Config{useithreads} ) { - plan tests => $nthreads; -} -else { - plan skip_all => 'no threads'; -} +plan tests => $Num_Threads; sub do_one_thread { @@ -52,7 +52,7 @@ sub do_one_thread { } my @kids = (); -for my $i (1..$nthreads) { +for my $i (1..$Num_Threads) { my $t = threads->new(\&do_one_thread, $i); print "# parent $$: continue\n"; push(@kids, $t); diff --git a/lib/Test/Simple/t/todo.t b/lib/Test/Simple/t/todo.t index 88b2e15..14a7b00 100644 --- a/lib/Test/Simple/t/todo.t +++ b/lib/Test/Simple/t/todo.t @@ -10,15 +10,18 @@ BEGIN { require Test::Harness; use Test::More; -# This feature requires a fairly new version of Test::Harness -(my $th_version = $Test::Harness::VERSION) =~ s/_//; # for X.Y_Z alpha versions +# Shut up a "used only once" warning in 5.5.4. +my $th_version = $Test::Harness::VERSION = $Test::Harness::VERSION; +$th_version =~ s/_//; # for X.Y_Z alpha versions + +# TODO requires a fairly new version of Test::Harness if( $th_version < 2.03 ) { plan tests => 1; fail "Need Test::Harness 2.03 or up. You have $th_version."; exit; } -plan tests => 16; +plan tests => 18; $Why = 'Just testing the todo interface.'; @@ -69,3 +72,20 @@ TODO: { die "todo_skip should prevent this"; pass("Again"); } + + +{ + my $warning; + local $SIG{__WARN__} = sub { $warning = join "", @_ }; + TODO: { + # perl gets the line number a little wrong on the first + # statement inside a block. + 1 == 1; +#line 82 + 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", + 'todo_skip without $how_many warning' ); +} diff --git a/lib/Test/Simple/t/undef.t b/lib/Test/Simple/t/undef.t index 00ce8b1..e9180bb 100644 --- a/lib/Test/Simple/t/undef.t +++ b/lib/Test/Simple/t/undef.t @@ -11,7 +11,7 @@ BEGIN { } use strict; -use Test::More tests => 14; +use Test::More tests => 16; use TieOut; BEGIN { $^W = 1; } @@ -58,3 +58,8 @@ $tb->failure_output($old_fail); is( $caught->read, "# undef\n" ); is( $warnings, '', 'diag(undef) no warnings' ); + + +$tb->maybe_regex(undef); +is( $caught->read, '' ); +is( $warnings, '', 'maybe_regex(undef) no warnings' );