From: Steve Peters Date: Wed, 19 Sep 2007 13:21:26 +0000 (+0000) Subject: Update to Test-Simple-0.71 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6b38a9b9a33daa1813fd9fa8b49a0acfe29fbe84;p=p5sagit%2Fp5-mst-13.2.git Update to Test-Simple-0.71 p4raw-id: //depot/perl@31907 --- diff --git a/MANIFEST b/MANIFEST index e5cb5c5..a8b5e51 100644 --- a/MANIFEST +++ b/MANIFEST @@ -2620,10 +2620,12 @@ lib/Test/Simple/README Test::Simple README 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_use_ok.t Test::More test lib/Test/Simple/t/buffer.t Test::Builder buffering test lib/Test/Simple/t/Builder.t Test::Builder tests 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/details.t Test::Builder tests @@ -2642,8 +2644,12 @@ 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 lib/Test/Simple/t/import.t Test::More test, importing functions +lib/Test/Simple/t/is_deeply_dne_bug.t Test::More test lib/Test/Simple/t/is_deeply_fail.t Test::More test, is_deeply() +lib/Test/Simple/t/is_deeply_with_threads.t Test::More test lib/Test/Simple/t/is_fh.t Test::Builder test, _is_fh() +lib/Test/Simple/t/lib/Dummy.pm Test::More test module +b/Test/Simple/t/lib/MyOverload.pm Test::More test module 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 @@ -2667,7 +2673,6 @@ 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/sort_bug.t Test::Simple 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 @@ -2678,6 +2683,7 @@ lib/Test/Simple/t/tbt_07args.t Test::Builder::Tester test lib/Test/Simple/t/threads.t Test::Builder thread-safe checks lib/Test/Simple/t/thread_taint.t Test::Simple test lib/Test/Simple/t/todo.t Test::More test, TODO tests +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() diff --git a/lib/Test/Builder.pm b/lib/Test/Builder.pm index 451a427..be50cad 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.70'; +$VERSION = '0.71'; $VERSION = eval $VERSION; # make the alpha version come out as a number # Make Test::Builder thread-safe for ithreads. @@ -1026,8 +1026,8 @@ sub is_fh { my $maybe_fh = shift; return 0 unless defined $maybe_fh; - 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 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 diff --git a/lib/Test/Builder/Module.pm b/lib/Test/Builder/Module.pm index 06604ea..0bfa4ab 100644 --- a/lib/Test/Builder/Module.pm +++ b/lib/Test/Builder/Module.pm @@ -5,7 +5,7 @@ use Test::Builder; require Exporter; @ISA = qw(Exporter); -$VERSION = '0.68'; +$VERSION = '0.71'; use strict; diff --git a/lib/Test/Builder/Tester.pm b/lib/Test/Builder/Tester.pm index afd9d62..db008ff 100644 --- a/lib/Test/Builder/Tester.pm +++ b/lib/Test/Builder/Tester.pm @@ -2,7 +2,7 @@ package Test::Builder::Tester; use strict; use vars qw(@EXPORT $VERSION @ISA); -$VERSION = "1.07"; +$VERSION = "1.08"; use Test::Builder; use Symbol; diff --git a/lib/Test/More.pm b/lib/Test/More.pm index 376726c..9ed402e 100644 --- a/lib/Test/More.pm +++ b/lib/Test/More.pm @@ -16,7 +16,7 @@ sub _carp { use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); -$VERSION = '0.70'; +$VERSION = '0.71'; $VERSION = eval $VERSION; # make the alpha version come out as a number use Test::Builder::Module; @@ -53,8 +53,8 @@ Test::More - yet another framework for writing test scripts # Various ways to say "ok" ok($got eq $expected, $test_name); - is ($got, $exptected, $test_name); - isnt($got, $expected, $test_name); + is ($got, $expected, $test_name); + isnt($got, $expected, $test_name); # Rather than print STDERR "# here's what went wrong\n" diag("here's what went wrong"); @@ -659,32 +659,37 @@ sub use_ok ($;@) { my($pack,$filename,$line) = caller; - local($@,$!,$SIG{__DIE__}); # isolate eval + # Work around a glitch in $@ and eval + my $eval_error; + { + local($@,$!,$SIG{__DIE__}); # isolate eval - 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 $ok = $tb->ok( !$eval_error, "use $module;" ); unless( $ok ) { - chomp $@; + chomp $eval_error; $@ =~ s{^BEGIN failed--compilation aborted at .*$} {BEGIN failed--compilation aborted at $filename line $line.}m; $tb->diag(<builder; @@ -852,8 +863,8 @@ sub _format_stack { foreach my $idx (0..$#vals) { my $val = $vals[$idx]; $vals[$idx] = !defined $val ? 'undef' : - $val eq $DNE ? "Does not exist" : - ref $val ? "$val" : + _dne($val) ? "Does not exist" : + ref $val ? "$val" : "'$val'"; } @@ -1222,7 +1233,7 @@ sub _deep_check { if( defined $e1 xor defined $e2 ) { $ok = 0; } - elsif ( $e1 == $DNE xor $e2 == $DNE ) { + elsif ( _dne($e1) xor _dne($e2) ) { $ok = 0; } elsif ( $same_ref and ($e1 eq $e2) ) { diff --git a/lib/Test/Simple.pm b/lib/Test/Simple.pm index 4d35a0d..52ce38e 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.70'; +$VERSION = '0.71'; $VERSION = eval $VERSION; # make the alpha version come out as a number use Test::Builder::Module; diff --git a/lib/Test/Simple/t/BEGIN_use_ok.t b/lib/Test/Simple/t/BEGIN_use_ok.t new file mode 100644 index 0000000..26caaa1 --- /dev/null +++ b/lib/Test/Simple/t/BEGIN_use_ok.t @@ -0,0 +1,28 @@ +#!/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 { + eval { + use_ok("Wibble"); + }; + $result = $@; +} + +plan tests => 1; +like $result, '/^You tried to run a test without a plan/'; diff --git a/lib/Test/Simple/t/More.t b/lib/Test/Simple/t/More.t index 1631895..b4bac92 100644 --- a/lib/Test/Simple/t/More.t +++ b/lib/Test/Simple/t/More.t @@ -7,7 +7,8 @@ BEGIN { } } -use Test::More tests => 51; +use lib 't/lib'; +use Test::More tests => 52; # Make sure we don't mess with $@ or $!. Test at bottom. my $Err = "this should not be touched"; @@ -15,7 +16,8 @@ my $Errno = 42; $@ = $Err; $! = $Errno; -use_ok('Text::Soundex'); +use_ok('Dummy'); +is( $Dummy::VERSION, '0.01', 'use_ok() loads a module' ); require_ok('Test::More'); diff --git a/lib/Test/Simple/t/cmp_ok.t b/lib/Test/Simple/t/cmp_ok.t new file mode 100644 index 0000000..b3642ad --- /dev/null +++ b/lib/Test/Simple/t/cmp_ok.t @@ -0,0 +1,82 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; + +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); +local $ENV{HARNESS_ACTIVE} = 0; + +require Test::Builder; +my $TB = Test::Builder->create; +$TB->level(0); + +sub try_cmp_ok { + my($left, $cmp, $right) = @_; + + my %expect; + $expect{ok} = eval "\$left $cmp \$right"; + $expect{error} = $@; + $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 $diag = $err->read; + if( !$ok and $expect{error} ) { + $diag =~ s/^# //mg; + $TB->like( $diag, "/\Q$expect{error}\E/" ); + } + elsif( $ok ) { + $TB->is_eq( $diag, '' ); + } + else { + $TB->ok(1); + } +} + + +use Test::More; +Test::More->builder->no_ending(1); + +my @Tests = ( + [1, '==', 1], + [1, '==', 2], + ["a", "eq", "b"], + ["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], + ); +} + +plan tests => scalar @Tests; +$TB->plan(tests => @Tests * 2); + +for my $test (@Tests) { + try_cmp_ok(@$test); +} diff --git a/lib/Test/Simple/t/fail-more.t b/lib/Test/Simple/t/fail-more.t index 57bd163..23bfd21 100644 --- a/lib/Test/Simple/t/fail-more.t +++ b/lib/Test/Simple/t/fail-more.t @@ -264,7 +264,6 @@ my $more_err_re = <read, "/^$more_err_re/"); diff --git a/lib/Test/Simple/t/is_deeply_dne_bug.t b/lib/Test/Simple/t/is_deeply_dne_bug.t new file mode 100644 index 0000000..56515f9 --- /dev/null +++ b/lib/Test/Simple/t/is_deeply_dne_bug.t @@ -0,0 +1,56 @@ +#!/usr/bin/perl -w + +# test for rt.cpan.org 20768 +# +# There was a bug where the internal "does not exist" object could get +# confused with an overloaded object. + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; +use Test::More; + +BEGIN { + if( !eval "require overload" ) { + plan skip_all => "needs overload.pm"; + } + else { + plan tests => 2; + } +} + +{ + package Foo; + + use overload + 'eq' => \&overload_equiv, + '==' => \&overload_equiv; + + sub new { + return bless {}, shift; + } + + sub overload_equiv { + if (ref($_[0]) ne 'Foo' || ref($_[1]) ne 'Foo') { + print ref($_[0]), " ", ref($_[1]), "\n"; + die "Invalid object passed to overload_equiv\n"; + } + + return 1; # change to 0 ... makes little difference + } +} + +my $obj1 = Foo->new(); +my $obj2 = Foo->new(); + +eval { is_deeply([$obj1, $obj2], [$obj1, $obj2]); }; +is $@, ''; + diff --git a/lib/Test/Simple/t/sort_bug.t b/lib/Test/Simple/t/is_deeply_with_threads.t similarity index 71% rename from lib/Test/Simple/t/sort_bug.t rename to lib/Test/Simple/t/is_deeply_with_threads.t index 03e3df2..4cc5426 100644 --- a/lib/Test/Simple/t/sort_bug.t +++ b/lib/Test/Simple/t/is_deeply_with_threads.t @@ -1,7 +1,6 @@ #!/usr/bin/perl -w -# Test to see if we've worked around some wacky sort/threading bug -# See [rt.cpan.org 6782] +# Test to see if is_deeply() plays well with threads. BEGIN { if( $ENV{PERL_CORE} ) { @@ -26,12 +25,9 @@ BEGIN { } 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 $Num_Threads = 2; +my $Num_Threads = 5; -plan tests => $Num_Threads; +plan tests => $Num_Threads * 100 + 5; sub do_one_thread { @@ -42,10 +38,8 @@ sub do_one_thread { my @list2 = @list; print "# kid $kid before eq_set\n"; - for my $j (1..99) { - # With eq_set, either crashes or panics - eq_set(\@list, \@list2); - eq_array(\@list, \@list2); + for my $j (1..100) { + is_deeply(\@list, \@list2); } print "# kid $kid exit\n"; return 42; diff --git a/lib/Test/Simple/t/is_fh.t b/lib/Test/Simple/t/is_fh.t index f4b1531..0eb3ec0 100644 --- a/lib/Test/Simple/t/is_fh.t +++ b/lib/Test/Simple/t/is_fh.t @@ -11,7 +11,7 @@ BEGIN { } use strict; -use Test::More tests => 10; +use Test::More tests => 11; use TieOut; ok( !Test::Builder->is_fh("foo"), 'string is not a filehandle' ); @@ -19,7 +19,7 @@ ok( !Test::Builder->is_fh(''), 'empty string' ); ok( !Test::Builder->is_fh(undef), 'undef' ); ok( open(FILE, '>foo') ); -END { close FILE; unlink 'foo' } +END { close FILE; 1 while unlink 'foo' } ok( Test::Builder->is_fh(*FILE) ); ok( Test::Builder->is_fh(\*FILE) ); @@ -34,3 +34,15 @@ SKIP: { unless defined *OUT{IO}; ok( Test::Builder->is_fh(*OUT{IO}) ); } + + +package Lying::isa; + +sub isa { + my $self = shift; + my $parent = shift; + + return 1 if $parent eq 'IO::Handle'; +} + +::ok( Test::Builder->is_fh(bless {}, "Lying::isa")); diff --git a/lib/Test/Simple/t/lib/Dummy.pm b/lib/Test/Simple/t/lib/Dummy.pm new file mode 100644 index 0000000..5e5b439 --- /dev/null +++ b/lib/Test/Simple/t/lib/Dummy.pm @@ -0,0 +1,5 @@ +package Dummy; + +$VERSION = '0.01'; + +1; \ No newline at end of file diff --git a/lib/Test/Simple/t/lib/MyOverload.pm b/lib/Test/Simple/t/lib/MyOverload.pm new file mode 100644 index 0000000..91632e9 --- /dev/null +++ b/lib/Test/Simple/t/lib/MyOverload.pm @@ -0,0 +1,29 @@ +package Overloaded; + +sub new { + my $class = shift; + bless { string => shift, num => shift }, $class; +} + + +package Overloaded::Compare; +use vars qw(@ISA); +@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] }; + + + +package Overloaded::Ify; +use vars qw(@ISA); +@ISA = qw(Overloaded); + +use overload + q{""} => sub { $_[0]->{string} }, + q{0+} => sub { $_[0]->{num} }; + +1; \ No newline at end of file diff --git a/lib/Test/Simple/t/output.t b/lib/Test/Simple/t/output.t index 72d0460..598d805 100644 --- a/lib/Test/Simple/t/output.t +++ b/lib/Test/Simple/t/output.t @@ -37,7 +37,7 @@ my $Test = Test::Builder->new(); my $result; my $tmpfile = 'foo.tmp'; my $out = $Test->output($tmpfile); -END { unlink($tmpfile) } +END { 1 while unlink($tmpfile) } ok( defined $out ); diff --git a/lib/Test/Simple/t/try.t b/lib/Test/Simple/t/try.t new file mode 100644 index 0000000..6e753a4 --- /dev/null +++ b/lib/Test/Simple/t/try.t @@ -0,0 +1,35 @@ +#!perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; + +use Test::More 'no_plan'; + +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