diff options
author | Rafael Garcia-Suarez <rgarciasuarez@gmail.com> | 2005-09-26 16:31:43 +0000 |
---|---|---|
committer | Rafael Garcia-Suarez <rgarciasuarez@gmail.com> | 2005-09-26 16:31:43 +0000 |
commit | b1ddf169801254979af17f682f37e96143b35982 (patch) | |
tree | 4008e1523b63a49dd8a8ffd0d73311bad93d53dc /lib | |
parent | 1bb1745960244153b0ed527cc2c3eb327b8de825 (diff) | |
download | perl-b1ddf169801254979af17f682f37e96143b35982.tar.gz |
Upgrade to Test::Simple 0.61
p4raw-id: //depot/perl@25604
Diffstat (limited to 'lib')
-rw-r--r-- | lib/Test/Builder.pm | 210 | ||||
-rw-r--r-- | lib/Test/Builder/Module.pm | 182 | ||||
-rw-r--r-- | lib/Test/More.pm | 546 | ||||
-rw-r--r-- | lib/Test/Simple.pm | 26 | ||||
-rw-r--r-- | lib/Test/Simple/Changes | 48 | ||||
-rw-r--r-- | lib/Test/Simple/t/00test_harness_check.t | 6 | ||||
-rw-r--r-- | lib/Test/Simple/t/bail_out.t | 49 | ||||
-rw-r--r-- | lib/Test/Simple/t/create.t | 20 | ||||
-rw-r--r-- | lib/Test/Simple/t/eq_set.t | 15 | ||||
-rw-r--r-- | lib/Test/Simple/t/exit.t | 5 | ||||
-rw-r--r-- | lib/Test/Simple/t/extra.t | 30 | ||||
-rw-r--r-- | lib/Test/Simple/t/extra_one.t | 25 | ||||
-rw-r--r-- | lib/Test/Simple/t/fail-like.t | 35 | ||||
-rw-r--r-- | lib/Test/Simple/t/fail-more.t | 194 | ||||
-rw-r--r-- | lib/Test/Simple/t/fail.t | 6 | ||||
-rw-r--r-- | lib/Test/Simple/t/fail_one.t | 2 | ||||
-rw-r--r-- | lib/Test/Simple/t/harness_active.t | 37 | ||||
-rw-r--r-- | lib/Test/Simple/t/has_plan2.t | 12 | ||||
-rw-r--r-- | lib/Test/Simple/t/is_deeply_fail.t | 53 | ||||
-rw-r--r-- | lib/Test/Simple/t/missing.t | 29 | ||||
-rw-r--r-- | lib/Test/Simple/t/no_diag.t | 4 | ||||
-rw-r--r-- | lib/Test/Simple/t/overload.t | 26 | ||||
-rw-r--r-- | lib/Test/Simple/t/plan_no_plan.t | 12 | ||||
-rw-r--r-- | lib/Test/Simple/t/todo.t | 12 | ||||
-rw-r--r-- | lib/Test/Simple/t/undef.t | 47 |
25 files changed, 1055 insertions, 576 deletions
diff --git a/lib/Test/Builder.pm b/lib/Test/Builder.pm index 859915b69e..b107633d3a 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.30'; +$VERSION = '0.31'; $VERSION = eval $VERSION; # make the alpha version come out as a number # Make Test::Builder thread-safe for ithreads. @@ -395,7 +395,7 @@ sub ok { $self->{Curr_Test}++; # In case $name is a string overloaded object, force it to stringify. - $self->_unoverload(\$name); + $self->_unoverload_str(\$name); $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/; You named your test '$name'. You shouldn't use numbers for your test names. @@ -405,7 +405,7 @@ ERR my($pack, $file, $line) = $self->caller; my $todo = $self->todo($pack); - $self->_unoverload(\$todo); + $self->_unoverload_str(\$todo); my $out; my $result = &share({}); @@ -448,7 +448,14 @@ ERR unless( $test ) { my $msg = $todo ? "Failed (TODO)" : "Failed"; $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE}; - $self->diag(" $msg test ($file at line $line)\n"); + + if( defined $name ) { + $self->diag(qq[ $msg test '$name'\n]); + $self->diag(qq[ in $file at line $line.\n]); + } + else { + $self->diag(qq[ $msg test in $file at line $line.\n]); + } } return $test ? 1 : 0; @@ -457,6 +464,7 @@ ERR sub _unoverload { my $self = shift; + my $type = shift; local($@,$!); @@ -464,8 +472,8 @@ sub _unoverload { foreach my $thing (@_) { eval { - if( defined $$thing ) { - if( my $string_meth = overload::Method($$thing, '""') ) { + if( _is_object($$thing) ) { + if( my $string_meth = overload::Method($$thing, $type) ) { $$thing = $$thing->$string_meth(); } } @@ -474,6 +482,42 @@ sub _unoverload { } +sub _is_object { + my $thing = shift; + + return eval { ref $thing && $thing->isa('UNIVERSAL') } ? 1 : 0; +} + + +sub _unoverload_str { + my $self = shift; + + $self->_unoverload(q[""], @_); +} + +sub _unoverload_num { + my $self = shift; + + $self->_unoverload('0+', @_); + + for my $val (@_) { + next unless $self->_is_dualvar($$val); + $$val = $$val+0; + } +} + + +# 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; +} + + + =item B<is_eq> $Test->is_eq($got, $expected, $name); @@ -494,6 +538,8 @@ sub is_eq { my($self, $got, $expect, $name) = @_; local $Level = $Level + 1; + $self->_unoverload_str(\$got, \$expect); + if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; @@ -510,6 +556,8 @@ sub is_num { my($self, $got, $expect, $name) = @_; local $Level = $Level + 1; + $self->_unoverload_num(\$got, \$expect); + if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; @@ -533,7 +581,7 @@ sub _is_diag { } else { # force numeric context - $$val = $$val+0; + $self->_unoverload_num($val); } } else { @@ -684,8 +732,6 @@ sub maybe_regex { sub _regex_ok { my($self, $this, $regex, $cmp, $name) = @_; - local $Level = $Level + 1; - my $ok = 0; my $usable_regex = $self->maybe_regex($regex); unless (defined $usable_regex) { @@ -695,9 +741,19 @@ sub _regex_ok { } { - local $^W = 0; - my $test = $this =~ /$usable_regex/ ? 1 : 0; + my $test; + my $code = $self->_caller_context; + + local($@, $!); + + # 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}; + $test = !$test if $cmp eq '!~'; + + local $Level = $Level + 1; $ok = $self->ok( $test, $name ); } @@ -724,15 +780,33 @@ Works just like Test::More's cmp_ok(). =cut + +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 $test; { - local $^W = 0; local($@,$!); # don't interfere with $@ # eval() sometimes resets $! - $test = eval "\$got $type \$expect"; + + my $code = $self->_caller_context; + + # 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;"; + } local $Level = $Level + 1; my $ok = $self->ok($test, $name); @@ -760,9 +834,22 @@ sub _cmp_diag { DIAGNOSTIC } -=item B<BAILOUT> - $Test->BAILOUT($reason); +sub _caller_context { + my $self = shift; + + my($pack, $file, $line) = $self->caller(1); + + my $code = ''; + $code .= "#line $line $file\n" if defined $file and defined $line; + + return $code; +} + + +=item B<BAIL_OUT> + + $Test->BAIL_OUT($reason); Indicates to the Test::Harness that things are going so badly all testing should terminate. This includes running any additional test @@ -772,13 +859,20 @@ It will exit with 255. =cut -sub BAILOUT { +sub BAIL_OUT { my($self, $reason) = @_; + $self->{Bailed_Out} = 1; $self->_print("Bail out! $reason"); exit 255; } +=for deprecated +BAIL_OUT() used to be BAILOUT() + +*BAILOUT = \&BAIL_OUT; + + =item B<skip> $Test->skip; @@ -791,7 +885,7 @@ Skips the current test, reporting $why. sub skip { my($self, $why) = @_; $why ||= ''; - $self->_unoverload(\$why); + $self->_unoverload_str(\$why); unless( $self->{Have_Plan} ) { require Carp; @@ -948,11 +1042,13 @@ sub use_numbers { return $self->{Use_Nums}; } -=item B<no_header> - $Test->no_header($no_header); +=item B<no_diag> -If set to true, no "1..N" header will be printed. + $Test->no_diag($no_diag); + +If set true no diagnostics will be printed. This includes calls to +diag(). =item B<no_ending> @@ -963,24 +1059,28 @@ ends. It also changes the exit code as described below. If this is true, none of that will be done. +=item B<no_header> + + $Test->no_header($no_header); + +If set to true, no "1..N" header will be printed. + =cut -sub no_header { - my($self, $no_header) = @_; +foreach my $attribute (qw(No_Header No_Ending No_Diag)) { + my $method = lc $attribute; - if( defined $no_header ) { - $self->{No_Header} = $no_header; - } - return $self->{No_Header}; -} + my $code = sub { + my($self, $no) = @_; -sub no_ending { - my($self, $no_ending) = @_; + if( defined $no ) { + $self->{$attribute} = $no; + } + return $self->{$attribute}; + }; - if( defined $no_ending ) { - $self->{No_Ending} = $no_ending; - } - return $self->{No_Ending}; + no strict 'refs'; + *{__PACKAGE__.'::'.$method} = $code; } @@ -1023,6 +1123,8 @@ Mark Fowler <mark@twoshortplanks.com> sub diag { my($self, @msgs) = @_; + + return if $self->no_diag; return unless @msgs; # Prevent printing headers when compiling (i.e. -c) @@ -1172,6 +1274,7 @@ sub _new_fh { sub _is_fh { my $maybe_fh = shift; + return 0 unless defined $maybe_fh; return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob @@ -1490,8 +1593,11 @@ sub _ending { # should do the ending. # Exit if plan() was never called. This is so "require Test::Simple" # doesn't puke. - if( ($self->{Original_Pid} != $$) or - (!$self->{Have_Plan} && !$self->{Test_Died}) ) + # 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; @@ -1516,26 +1622,31 @@ sub _ending { } my $num_failed = grep !$_->{'ok'}, - @{$test_results}[0..$self->{Expected_Tests}-1]; - $num_failed += abs($self->{Expected_Tests} - @$test_results); + @{$test_results}[0..$self->{Curr_Test}-1]; - if( $self->{Curr_Test} < $self->{Expected_Tests} ) { + 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( $self->{Curr_Test} > $self->{Expected_Tests} ) { - my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; + elsif( $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. FAIL } - elsif ( $num_failed ) { + + if ( $num_failed ) { + my $num_tests = $self->{Curr_Test}; my $s = $num_failed == 1 ? '' : 's'; + + my $qualifier = $num_extra == 0 ? '' : ' run'; + $self->diag(<<"FAIL"); -Looks like you failed $num_failed test$s of $self->{Expected_Tests}. +Looks like you failed $num_failed test$s of $num_tests$qualifier. FAIL } @@ -1547,7 +1658,18 @@ FAIL _my_exit( 255 ) && return; } - _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return; + my $exit_code; + if( $num_failed ) { + $exit_code = $num_failed <= 254 ? $num_failed : 254; + } + elsif( $num_extra != 0 ) { + $exit_code = 255; + } + else { + $exit_code = 0; + } + + _my_exit( $exit_code ) && return; } elsif ( $self->{Skip_All} ) { _my_exit( 0 ) && return; @@ -1581,7 +1703,7 @@ considered a failure and will exit with 255. So the exit codes are... 0 all tests successful - 255 test died + 255 test died or all passed but wrong # of tests run any other number how many failed (including missing or extras) If you fail more than 254 tests, it will be reported as 254. diff --git a/lib/Test/Builder/Module.pm b/lib/Test/Builder/Module.pm new file mode 100644 index 0000000000..b3ccce6329 --- /dev/null +++ b/lib/Test/Builder/Module.pm @@ -0,0 +1,182 @@ +package Test::Builder::Module; + +use Test::Builder; + +require Exporter; +@ISA = qw(Exporter); + +$VERSION = '0.02'; + +use strict; + +# 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, @_); +}; + + +=head1 NAME + +Test::Builder::Module - Base class for test modules + +=head1 SYNOPSIS + + # Emulates Test::Simple + package Your::Module; + + my $CLASS = __PACKAGE__; + + use base 'Test::Builder::Module'; + @EXPORT = qw(ok); + + sub ok ($;$) { + my $tb = $CLASS->builder; + return $tb->ok(@_); + } + + 1; + + +=head1 DESCRIPTION + +This is a superclass for Test::Builder-based modules. It provides a +handful of common functionality and a method of getting at the underlying +Test::Builder object. + + +=head2 Importing + +Test::Builder::Module is a subclass of Exporter which means your +module is also a subclass of Exporter. @EXPORT, @EXPORT_OK, etc... +all act normally. + +A few methods are provided to do the C<use Your::Module tests => 23> part +for you. + +=head3 import + +Test::Builder::Module provides an import() method which acts in the +same basic way as Test::More's, setting the plan and controling +exporting of functions and variables. This allows your module to set +the plan independent of Test::More. + +All arguments passed to import() are passed onto +C<< Your::Module->builder->plan() >> with the exception of +C<import =>[qw(things to import)]>. + + use Your::Module import => [qw(this that)], tests => 23; + +says to import the functions this() and that() as well as set the plan +to be 23 tests. + +import() also sets the exported_to() attribute of your builder to be +the caller of the import() function. + +Additional behaviors can be added to your import() method by overriding +import_extra(). + +=cut + +sub import { + my($class) = shift; + + my $test = $class->builder; + + my $caller = caller; + + $test->exported_to($caller); + + $class->import_extra(\@_); + my(@imports) = $class->_strip_imports(\@_); + + $test->plan(@_); + + $class->$_export_to_level(1, $class, @imports); +} + + +sub _strip_imports { + my $class = shift; + my $list = shift; + + my @imports = (); + my @other = (); + my $idx = 0; + while( $idx <= $#{$list} ) { + my $item = $list->[$idx]; + + if( defined $item and $item eq 'import' ) { + push @imports, @{$list->[$idx+1]}; + $idx++; + } + else { + push @other, $item; + } + + $idx++; + } + + @$list = @other; + + return @imports; +} + + +=head3 import_extra + + Your::Module->import_extra(\@import_args); + +import_extra() is called by import(). It provides an opportunity for you +to add behaviors to your module based on its import list. + +Any extra arguments which shouldn't be passed on to plan() should be +stripped off by this method. + +See Test::More for an example of its use. + +B<NOTE> This mechanism is I<VERY ALPHA AND LIKELY TO CHANGE> as it +feels like a bit of an ugly hack in its current form. + +=cut + +sub import_extra {} + + +=head2 Builder + +Test::Builder::Module provides some methods of getting at the underlying +Test::Builder object. + +=head3 builder + + my $builder = Your::Class->builder; + +This method returns the Test::Builder object associated with Your::Class. +It is not a constructor so you can call it as often as you like. + +This is the preferred way to get the Test::Builder object. You should +I<not> get it via C<< Test::Builder->new >> as was previously +recommended. + +The object returned by builder() may change at runtime so you should +call builder() inside each function rather than store it in a global. + + sub ok { + my $builder = Your::Class->builder; + + return $builder->ok(@_); + } + + +=cut + +sub builder { + return Test::Builder->new; +} + + +1; diff --git a/lib/Test/More.pm b/lib/Test/More.pm index 3183a60de4..c305dd038b 100644 --- a/lib/Test/More.pm +++ b/lib/Test/More.pm @@ -3,7 +3,6 @@ package Test::More; use 5.004; use strict; -use Test::Builder; # Can't use Carp because it might cause use_ok() to accidentally succeed @@ -16,12 +15,12 @@ sub _carp { -require Exporter; use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); -$VERSION = '0.60'; +$VERSION = '0.61'; $VERSION = eval $VERSION; # make the alpha version come out as a number -@ISA = qw(Exporter); +use Test::Builder::Module; +@ISA = qw(Test::Builder::Module); @EXPORT = qw(ok use_ok require_ok is isnt like unlike is_deeply cmp_ok @@ -32,22 +31,9 @@ $VERSION = eval $VERSION; # make the alpha version come out as a number plan can_ok isa_ok diag + BAIL_OUT ); -my $Test = Test::Builder->new; -my $Show_Diag = 1; - - -# 5.004's Exporter doesn't have export_to_level. -sub _export_to_level -{ - my $pkg = shift; - my $level = shift; - (undef) = shift; # redundant arg - my $callpkg = caller($level); - $pkg->export($callpkg, @_); -} - =head1 NAME @@ -100,11 +86,10 @@ Test::More - yet another framework for writing test scripts pass($test_name); fail($test_name); - # UNIMPLEMENTED!!! - my @status = Test::More::status; + BAIL_OUT($why); # UNIMPLEMENTED!!! - BAIL_OUT($why); + my @status = Test::More::status; =head1 DESCRIPTION @@ -137,7 +122,7 @@ have no plan. (Try to avoid using this as it weakens your test.) use Test::More qw(no_plan); B<NOTE>: using no_plan requires a Test::Harness upgrade else it will -think everything has failed. See L<BUGS and CAVEATS>) +think everything has failed. See L<CAVEATS and NOTES>). In some cases, you'll want to completely skip an entire testing script. @@ -172,53 +157,34 @@ or for deciding between running the tests at all: =cut sub plan { - my(@plan) = @_; - - my $idx = 0; - my @cleaned_plan; - while( $idx <= $#plan ) { - my $item = $plan[$idx]; + my $tb = Test::More->builder; - if( $item eq 'no_diag' ) { - $Show_Diag = 0; - } - else { - push @cleaned_plan, $item; - } - - $idx++; - } - - $Test->plan(@cleaned_plan); + $tb->plan(@_); } -sub import { - my($class) = shift; - - my $caller = caller; - $Test->exported_to($caller); +# This implements "use Test::More 'no_diag'" but the behavior is +# deprecated. +sub import_extra { + my $class = shift; + my $list = shift; + my @other = (); my $idx = 0; - my @plan; - my @imports; - while( $idx <= $#_ ) { - my $item = $_[$idx]; - - if( $item eq 'import' ) { - push @imports, @{$_[$idx+1]}; - $idx++; + while( $idx <= $#{$list} ) { + my $item = $list->[$idx]; + + if( defined $item and $item eq 'no_diag' ) { + $class->builder->no_diag(1); } else { - push @plan, $item; + push @other, $item; } $idx++; } - plan(@plan); - - __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); + @$list = @other; } @@ -283,7 +249,8 @@ but we B<very> strongly encourage its use. Should an ok() fail, it will produce some diagnostics: not ok 18 - sufficient mucus - # Failed test 18 (foo.t at line 42) + # Failed test 'sufficient mucus' + # in foo.t at line 42. This is actually Test::Simple's ok() routine. @@ -291,7 +258,9 @@ This is actually Test::Simple's ok() routine. sub ok ($;$) { my($test, $name) = @_; - $Test->ok($test, $name); + my $tb = Test::More->builder; + + $tb->ok($test, $name); } =item B<is> @@ -329,7 +298,8 @@ test: Will produce something like this: not ok 17 - Is foo the same as bar? - # Failed test (foo.t at line 139) + # Failed test 'Is foo the same as bar?' + # in foo.t at line 139. # got: 'waffle' # expected: 'yarblokos' @@ -354,11 +324,15 @@ function which is an alias of isnt(). =cut sub is ($$;$) { - $Test->is_eq(@_); + my $tb = Test::More->builder; + + $tb->is_eq(@_); } sub isnt ($$;$) { - $Test->isnt_eq(@_); + my $tb = Test::More->builder; + + $tb->isnt_eq(@_); } *isn't = \&isnt; @@ -395,7 +369,9 @@ diagnostics on failure. =cut sub like ($$;$) { - $Test->like(@_); + my $tb = Test::More->builder; + + $tb->like(@_); } @@ -409,7 +385,9 @@ given pattern. =cut sub unlike ($$;$) { - $Test->unlike(@_); + my $tb = Test::More->builder; + + $tb->unlike(@_); } @@ -434,7 +412,7 @@ Its advantage over ok() is when the test fails you'll know what $this and $that were: not ok 1 - # Failed test (foo.t at line 12) + # Failed test in foo.t at line 12. # '23' # && # undef @@ -447,7 +425,9 @@ is()'s use of C<eq> will interfere: =cut sub cmp_ok($$$;$) { - $Test->cmp_ok(@_); + my $tb = Test::More->builder; + + $tb->cmp_ok(@_); } @@ -483,10 +463,11 @@ as one test. If you desire otherwise, use: sub can_ok ($@) { my($proto, @methods) = @_; my $class = ref $proto || $proto; + my $tb = Test::More->builder; unless( @methods ) { - my $ok = $Test->ok( 0, "$class->can(...)" ); - $Test->diag(' can_ok() called with no methods'); + my $ok = $tb->ok( 0, "$class->can(...)" ); + $tb->diag(' can_ok() called with no methods'); return $ok; } @@ -501,9 +482,9 @@ sub can_ok ($@) { $name = @methods == 1 ? "$class->can('$methods[0]')" : "$class->can(...)"; - my $ok = $Test->ok( !@nok, $name ); + my $ok = $tb->ok( !@nok, $name ); - $Test->diag(map " $class->can('$_') failed\n", @nok); + $tb->diag(map " $class->can('$_') failed\n", @nok); return $ok; } @@ -539,6 +520,7 @@ you'd like them to be more specific, you can supply an $object_name sub isa_ok ($$;$) { my($object, $class, $obj_name) = @_; + my $tb = Test::More->builder; my $diag; $obj_name = 'The object' unless defined $obj_name; @@ -578,11 +560,11 @@ WHOA my $ok; if( $diag ) { - $ok = $Test->ok( 0, $name ); - $Test->diag(" $diag\n"); + $ok = $tb->ok( 0, $name ); + $tb->diag(" $diag\n"); } else { - $ok = $Test->ok( 1, $name ); + $ok = $tb->ok( 1, $name ); } return $ok; @@ -607,65 +589,17 @@ Use these very, very, very sparingly. =cut sub pass (;$) { - $Test->ok(1, @_); + my $tb = Test::More->builder; + $tb->ok(1, @_); } sub fail (;$) { - $Test->ok(0, @_); + my $tb = Test::More->builder; + $tb->ok(0, @_); } =back -=head2 Diagnostics - -If you pick the right test function, you'll usually get a good idea of -what went wrong when it failed. But sometimes it doesn't work out -that way. So here we have ways for you to write your own diagnostic -messages which are safer than just C<print STDERR>. - -=over 4 - -=item B<diag> - - diag(@diagnostic_message); - -Prints a diagnostic message which is guaranteed not to interfere with -test output. Like C<print> @diagnostic_message is simply concatenated -together. - -Handy for this sort of thing: - - ok( grep(/foo/, @users), "There's a foo user" ) or - diag("Since there's no foo, check that /etc/bar is set up right"); - -which would produce: - - not ok 42 - There's a foo user - # Failed test (foo.t at line 52) - # Since there's no foo, check that /etc/bar is set up right. - -You might remember C<ok() or diag()> with the mnemonic C<open() or -die()>. - -All diag()s can be made silent by passing the "no_diag" option to -Test::More. C<use Test::More tests => 1, 'no_diag'>. This is useful -if you have diagnostics for personal testing but then wish to make -them silent for release without commenting out each individual -statement. - -B<NOTE> The exact formatting of the diagnostic output is still -changing, but it is guaranteed that whatever you throw at it it won't -interfere with the test. - -=cut - -sub diag { - return unless $Show_Diag; - $Test->diag(@_); -} - - -=back =head2 Module tests @@ -718,6 +652,7 @@ because the notion of "compile-time" is relative. Instead, you want: sub use_ok ($;@) { my($module, @imports) = @_; @imports = () unless @imports; + my $tb = Test::More->builder; my($pack,$filename,$line) = caller; @@ -738,13 +673,13 @@ use $module \@imports; USE } - my $ok = $Test->ok( !$@, "use $module;" ); + my $ok = $tb->ok( !$@, "use $module;" ); unless( $ok ) { chomp $@; $@ =~ s{^BEGIN failed--compilation aborted at .*$} {BEGIN failed--compilation aborted at $filename line $line.}m; - $Test->diag(<<DIAGNOSTIC); + $tb->diag(<<DIAGNOSTIC); Tried to use '$module'. Error: $@ DIAGNOSTIC @@ -765,6 +700,7 @@ Like use_ok(), except it requires the $module or $file. sub require_ok ($) { my($module) = shift; + my $tb = Test::More->builder; my $pack = caller; @@ -778,11 +714,11 @@ package $pack; require $module; REQUIRE - my $ok = $Test->ok( !$@, "require $module;" ); + my $ok = $tb->ok( !$@, "require $module;" ); unless( $ok ) { chomp $@; - $Test->diag(<<DIAGNOSTIC); + $tb->diag(<<DIAGNOSTIC); Tried to require '$module'. Error: $@ DIAGNOSTIC @@ -805,6 +741,185 @@ sub _is_module_name { =back + +=head2 Complex data structures + +Not everything is a simple eq check or regex. There are times you +need to see if two data structures are equivalent. For these +instances Test::More provides a handful of useful functions. + +B<NOTE> I'm not quite sure what will happen with filehandles. + +=over 4 + +=item B<is_deeply> + + is_deeply( $this, $that, $test_name ); + +Similar to is(), except that if $this and $that are references, it +does a deep comparison walking each data structure to see if they are +equivalent. If the two structures are different, it will display the +place where they start differing. + +is_deeply() compares the dereferenced values of references, the +references themselves (except for their type) are ignored. This means +aspects such as blessing and ties are not considered "different". + +Test::Differences and Test::Deep provide more in-depth functionality +along these lines. + +=cut + +use vars qw(@Data_Stack %Refs_Seen); +my $DNE = bless [], 'Does::Not::Exist'; +sub is_deeply { + my $tb = Test::More->builder; + + unless( @_ == 2 or @_ == 3 ) { + my $msg = <<WARNING; +is_deeply() takes two or three args, you gave %d. +This usually means you passed an array or hash instead +of a reference to it +WARNING + chop $msg; # clip off newline so carp() will put in line/file + + _carp sprintf $msg, scalar @_; + + return $tb->ok(0); + } + + my($this, $that, $name) = @_; + + $tb->_unoverload_str(\$that, \$this); + + my $ok; + if( !ref $this and !ref $that ) { # neither is a reference + $ok = $tb->is_eq($this, $that, $name); + } + elsif( !ref $this xor !ref $that ) { # one's a reference, one isn't + $ok = $tb->ok(0, $name); + $tb->diag( _format_stack({ vals => [ $this, $that ] }) ); + } + else { # both references + local @Data_Stack = (); + if( _deep_check($this, $that) ) { + $ok = $tb->ok(1, $name); + } + else { + $ok = $tb->ok(0, $name); + $tb->diag(_format_stack(@Data_Stack)); + } + } + + return $ok; +} + +sub _format_stack { + my(@Stack) = @_; + + my $var = '$FOO'; + my $did_arrow = 0; + foreach my $entry (@Stack) { + my $type = $entry->{type} || ''; + my $idx = $entry->{'idx'}; + if( $type eq 'HASH' ) { + $var .= "->" unless $did_arrow++; + $var .= "{$idx}"; + } + elsif( $type eq 'ARRAY' ) { + $var .= "->" unless $did_arrow++; + $var .= "[$idx]"; + } + elsif( $type eq 'REF' ) { + $var = "\${$var}"; + } + } + + my @vals = @{$Stack[-1]{vals}}[0,1]; + my @vars = (); + ($vars[0] = $var) =~ s/\$FOO/ \$got/; + ($vars[1] = $var) =~ s/\$FOO/\$expected/; + + my $out = "Structures begin differing at:\n"; + foreach my $idx (0..$#vals) { + my $val = $vals[$idx]; + $vals[$idx] = !defined $val ? 'undef' : + $val eq $DNE ? "Does not exist" : + ref $val ? "$val" : + "'$val'"; + } + + $out .= "$vars[0] = $vals[0]\n"; + $out .= "$vars[1] = $vals[1]\n"; + + $out =~ s/^/ /msg; + return $out; +} + + +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 ''; +} + +=back + + +=head2 Diagnostics + +If you pick the right test function, you'll usually get a good idea of +what went wrong when it failed. But sometimes it doesn't work out +that way. So here we have ways for you to write your own diagnostic +messages which are safer than just C<print STDERR>. + +=over 4 + +=item B<diag> + + diag(@diagnostic_message); + +Prints a diagnostic message which is guaranteed not to interfere with +test output. Like C<print> @diagnostic_message is simply concatenated +together. + +Handy for this sort of thing: + + ok( grep(/foo/, @users), "There's a foo user" ) or + diag("Since there's no foo, check that /etc/bar is set up right"); + +which would produce: + + not ok 42 - There's a foo user + # Failed test 'There's a foo user' + # in foo.t at line 52. + # Since there's no foo, check that /etc/bar is set up right. + +You might remember C<ok() or diag()> with the mnemonic C<open() or +die()>. + +B<NOTE> The exact formatting of the diagnostic output is still +changing, but it is guaranteed that whatever you throw at it it won't +interfere with the test. + +=cut + +sub diag { + my $tb = Test::More->builder; + + $tb->diag(@_); +} + + +=back + + =head2 Conditional tests Sometimes running a test under certain conditions will cause the @@ -867,16 +982,17 @@ use TODO. Read on. #'# sub skip { my($why, $how_many) = @_; + my $tb = Test::More->builder; 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->has_plan eq 'no_plan'; + unless $tb->has_plan eq 'no_plan'; $how_many = 1; } for( 1..$how_many ) { - $Test->skip($why); + $tb->skip($why); } local $^W = 0; @@ -922,7 +1038,7 @@ Once a todo test starts succeeding, simply move it outside the block. When the block is empty, delete it. B<NOTE>: TODO tests require a Test::Harness upgrade else it will -treat it as a normal failure. See L<BUGS and CAVEATS>) +treat it as a normal failure. See L<CAVEATS and NOTES>). =item B<todo_skip> @@ -947,16 +1063,17 @@ interpret them as passing. sub todo_skip { my($why, $how_many) = @_; + my $tb = Test::More->builder; 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->has_plan eq 'no_plan'; + unless $tb->has_plan eq 'no_plan'; $how_many = 1; } for( 1..$how_many ) { - $Test->todo_skip($why); + $tb->todo_skip($why); } local $^W = 0; @@ -977,124 +1094,34 @@ but want to put tests in your testing script (always a good idea). =back -=head2 Complex data structures -Not everything is a simple eq check or regex. There are times you -need to see if two data structures are equivalent. For these -instances Test::More provides a handful of useful functions. - -B<NOTE> I'm not quite sure what will happen with filehandles. +=head2 Test control =over 4 -=item B<is_deeply> +=item B<BAIL_OUT> - is_deeply( $this, $that, $test_name ); + BAIL_OUT($reason); -Similar to is(), except that if $this and $that are hash or array -references, it does a deep comparison walking each data structure to -see if they are equivalent. If the two structures are different, it -will display the place where they start differing. +Incidates to the harness that things are going so badly all testing +should terminate. This includes the running any additional test scripts. -Test::Differences and Test::Deep provide more in-depth functionality -along these lines. +This is typically used when testing cannot continue such as a critical +module failing to compile or a necessary external utility not being +available such as a database connection failing. -=cut +The test will exit with 255. -use vars qw(@Data_Stack %Refs_Seen); -my $DNE = bless [], 'Does::Not::Exist'; -sub is_deeply { - unless( @_ == 2 or @_ == 3 ) { - my $msg = <<WARNING; -is_deeply() takes two or three args, you gave %d. -This usually means you passed an array or hash instead -of a reference to it -WARNING - chop $msg; # clip off newline so carp() will put in line/file - - _carp sprintf $msg, scalar @_; - - return $Test->ok(0); - } - - my($this, $that, $name) = @_; - - my $ok; - if( !ref $this and !ref $that ) { # neither is a reference - $ok = $Test->is_eq($this, $that, $name); - } - elsif( !ref $this xor !ref $that ) { # one's a reference, one isn't - $ok = $Test->ok(0, $name); - $Test->diag( _format_stack({ vals => [ $this, $that ] }) ); - } - else { # both references - local @Data_Stack = (); - if( _deep_check($this, $that) ) { - $ok = $Test->ok(1, $name); - } - else { - $ok = $Test->ok(0, $name); - $Test->diag(_format_stack(@Data_Stack)); - } - } - - return $ok; -} - -sub _format_stack { - my(@Stack) = @_; - - my $var = '$FOO'; - my $did_arrow = 0; - foreach my $entry (@Stack) { - my $type = $entry->{type} || ''; - my $idx = $entry->{'idx'}; - if( $type eq 'HASH' ) { - $var .= "->" unless $did_arrow++; - $var .= "{$idx}"; - } - elsif( $type eq 'ARRAY' ) { - $var .= "->" unless $did_arrow++; - $var .= "[$idx]"; - } - elsif( $type eq 'REF' ) { - $var = "\${$var}"; - } - } - - my @vals = @{$Stack[-1]{vals}}[0,1]; - my @vars = (); - ($vars[0] = $var) =~ s/\$FOO/ \$got/; - ($vars[1] = $var) =~ s/\$FOO/\$expected/; - - my $out = "Structures begin differing at:\n"; - foreach my $idx (0..$#vals) { - my $val = $vals[$idx]; - $vals[$idx] = !defined $val ? 'undef' : - $val eq $DNE ? "Does not exist" : - ref $val ? "$val" : - "'$val'"; - } +=cut - $out .= "$vars[0] = $vals[0]\n"; - $out .= "$vars[1] = $vals[1]\n"; +sub BAIL_OUT { + my $reason = shift; + my $tb = Test::More->builder; - $out =~ s/^/ /msg; - return $out; + $tb->BAIL_OUT($reason); } - -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 ''; -} +=back =head2 Discouraged comparison functions @@ -1115,6 +1142,7 @@ C<is_deeply()> can do that better and with diagnostics. They may be deprecated in future versions. +=over 4 =item B<eq_array> @@ -1159,6 +1187,8 @@ sub _eq_array { sub _deep_check { my($e1, $e2) = @_; + my $tb = Test::More->builder; + my $ok = 0; # Effectively turn %Refs_Seen into a stack. This avoids picking up @@ -1170,7 +1200,7 @@ sub _deep_check { # Quiet uninitialized value warnings when comparing undefs. local $^W = 0; - $Test->_unoverload(\$e1, \$e2); + $tb->_unoverload_str(\$e1, \$e2); # Either they're both references or both not. my $same_ref = !(!ref $e1 xor !ref $e2); @@ -1298,6 +1328,11 @@ Is better written: B<NOTE> By historical accident, this is not a true set comparison. While the order of elements does not matter, duplicate elements do. +B<NOTE> eq_set() does not know how to deal with references at the top +level. The following is an example of a comparison which might not work: + + eq_set([\1, \2], [\2, \1]); + Test::Deep contains much better set comparison functions. =cut @@ -1309,14 +1344,20 @@ sub eq_set { # There's faster ways to do this, but this is easiest. local $^W = 0; - # We must make sure that references are treated neutrally. It really - # doesn't matter how we sort them, as long as both arrays are sorted - # with the same algorithm. + # 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 + # string containing the reference. + # # Have to inline the sort routine due to a threading/sort bug. # See [rt.cpan.org 6782] + # + # 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( - [sort { ref $a ? -1 : ref $b ? 1 : $a cmp $b } @$a1], - [sort { ref $a ? -1 : ref $b ? 1 : $a cmp $b } @$a2] + [grep(ref, @$a1), sort( grep(!ref, @$a1) )], + [grep(ref, @$a2), sort( grep(!ref, @$a2) )], ); } @@ -1343,11 +1384,6 @@ you can access the underlying Test::Builder object like so: Returns the Test::Builder object underlying Test::More for you to play with. -=cut - -sub builder { - return Test::Builder->new; -} =back @@ -1365,7 +1401,7 @@ considered a failure and will exit with 255. So the exit codes are... 0 all tests successful - 255 test died + 255 test died or all passed but wrong # of tests run any other number how many failed (including missing or extras) If you fail more than 254 tests, it will be reported as 254. @@ -1384,10 +1420,12 @@ Test::More works with Perls as old as 5.004_05. =item Overloaded objects -String overloaded objects are compared B<as strings>. This prevents -Test::More from piercing an object's interface allowing better blackbox -testing. So if a function starts returning overloaded objects instead of -bare strings your tests won't notice the difference. This is good. +String overloaded objects are compared B<as strings> (or in cmp_ok()'s +case, strings or numbers as appropriate to the comparison op). This +prevents Test::More from piercing an object's interface allowing +better blackbox testing. So if a function starts returning overloaded +objects instead of bare strings your tests won't notice the +difference. This is good. 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 diff --git a/lib/Test/Simple.pm b/lib/Test/Simple.pm index f84ac5e0ad..74cb1fcc89 100644 --- a/lib/Test/Simple.pm +++ b/lib/Test/Simple.pm @@ -3,22 +3,15 @@ package Test::Simple; use 5.004; use strict 'vars'; -use vars qw($VERSION); -$VERSION = '0.60'; +use vars qw($VERSION @ISA @EXPORT); +$VERSION = '0.61'; $VERSION = eval $VERSION; # make the alpha version come out as a number +use Test::Builder::Module; +@ISA = qw(Test::Builder::Module); +@EXPORT = qw(ok); -use Test::Builder; -my $Test = Test::Builder->new; - -sub import { - my $self = shift; - my $caller = caller; - *{$caller.'::ok'} = \&ok; - - $Test->exported_to($caller); - $Test->plan(@_); -} +my $CLASS = __PACKAGE__; =head1 NAME @@ -85,7 +78,7 @@ will do what you mean (fail if stuff is empty) =cut sub ok ($;$) { - $Test->ok(@_); + $CLASS->builder->ok(@_); } @@ -107,7 +100,7 @@ considered a failure and will exit with 255. So the exit codes are... 0 all tests successful - 255 test died + 255 test died or all passed but wrong # of tests run any other number how many failed (including missing or extras) If you fail more than 254 tests, it will be reported as 254. @@ -144,7 +137,8 @@ It will produce output like this: ok 2 - Title() get ok 3 - Director() get not ok 4 - Rating() get - # Failed test (t/film.t at line 14) + # Failed test 'Rating() get' + # in t/film.t at line 14. ok 5 - NumExplodingSheep() get # Looks like you failed 1 tests of 5 diff --git a/lib/Test/Simple/Changes b/lib/Test/Simple/Changes index d046129cae..2f44ab67f7 100644 --- a/lib/Test/Simple/Changes +++ b/lib/Test/Simple/Changes @@ -1,3 +1,51 @@ +0.61 Fri Sep 23 23:26:05 PDT 2005 + - create.t was trying to read from a file before it had been closed + (and thus the changes may not have yet been written). + * is_deeply() would call stringification methods on non-object strings + which happened to be the name of a string overloaded class. + [rt.cpan.org 14675] + +0.60_02 Tue Aug 9 00:27:41 PDT 2005 + * Added Test::Builder::Module. + - Changed Test::More and Test::Simple to use Test::Builder::Module + - Minor Win32 testing nit in fail-more.t + * Added no_diag() method to Test::Builder and changed Test::More's + no_diag internals to use that. [rt.cpan.org 8655] + * Deprecated no_diag() as an option to "use Test::More". Call the + Test::Builder method instead. + +0.60_01 Sun Jul 3 18:11:58 PDT 2005 + - Moved the docs around a little to better group all the testing + functions together. [rt.cpan.org 8388] + * Added a BAIL_OUT() function to Test::More [rt.cpan.org 8381] + - Changed Test::Builder->BAILOUT to BAIL_OUT to match other method's + naming conventions. BAILOUT remains but is deprecated. + * Changed the standard failure diagnostics to include the test name. + [rt.cpan.org 12490] + - is_deeply() was broken for overloaded objects in the top level in + 0.59_01. [rt.cpan.org 13506] + - String overloaded objects without an 'eq' or '==' method are now + handled in cmp_ok() and is(). + - cmp_ok() will now treat overloaded objects as numbers if the comparison + operator is numeric. [rt.cpan.org 13156] + - cmp_ok(), like() and unlike will now throw uninit warnings if their + arguments are undefined. [rt.cpan.org 13155] + - cmp_ok() will now throw warnings as if the comparison were run + normally, for example cmp_ok(2, '==', 'foo') will warn about 'foo' + not being numeric. Previously all warnings in the comparison were + supressed. [rt.cpan.org 13155] + - Tests will now report *both* the number of tests failed and if the + wrong number of tests were run. Previously if tests failed and the + wrong number were run it would only report the latter. + [rt.cpan.org 13494] + - Missing or extra tests are not considered failures for the purposes + of calculating the exit code. Should there be no failures but the + wrong number of tests the exit code will be 254. + - Avoiding an unbalanced sort in eq_set() [bugs.perl.org 36354] + - Documenting that eq_set() doesn't deal well with refs. + - Clarified how is_deeply() compares a bit. + * Once again working on 5.4.5. + 0.60 Tue May 3 14:20:34 PDT 2005 0.59_01 Tue Apr 26 21:51:12 PDT 2005 diff --git a/lib/Test/Simple/t/00test_harness_check.t b/lib/Test/Simple/t/00test_harness_check.t index 7a290f4877..d50c8b5ffd 100644 --- a/lib/Test/Simple/t/00test_harness_check.t +++ b/lib/Test/Simple/t/00test_harness_check.t @@ -5,12 +5,14 @@ use Test::More; plan tests => 1; +my $TH_Version = 2.03; + require Test::Harness; -unless( cmp_ok( $Test::Harness::VERSION, '>', 1.20, "T::H version" ) ) { +unless( cmp_ok( $Test::Harness::VERSION, '>', $TH_Version, "T::H version" ) ) { diag <<INSTRUCTIONS; Test::Simple/More/Builder has features which depend on a version of -Test::Harness greater than 1.20. You have $Test::Harness::VERSION. +Test::Harness greater than $TH_Version. You have $Test::Harness::VERSION. Please install a new version from CPAN. If you've already tried to upgrade Test::Harness and still get this diff --git a/lib/Test/Simple/t/bail_out.t b/lib/Test/Simple/t/bail_out.t new file mode 100644 index 0000000000..c05d0283d1 --- /dev/null +++ b/lib/Test/Simple/t/bail_out.t @@ -0,0 +1,49 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +my $Exit_Code; +BEGIN { + *CORE::GLOBAL::exit = sub { $Exit_Code = shift; }; +} + + +use Test::Builder; +use Test::More; +use TieOut; + +my $output = tie *FAKEOUT, 'TieOut'; +my $TB = Test::More->builder; +$TB->output(\*FAKEOUT); + +my $Test = Test::Builder->create; +$Test->level(0); + +if( $] >= 5.005 ) { + $Test->plan(tests => 2); +} +else { + $Test->plan(skip_all => + 'CORE::GLOBAL::exit, introduced in 5.005, is needed for testing'); +} + + +plan tests => 4; + +BAIL_OUT("ROCKS FALL! EVERYONE DIES!"); + + +$Test->is_eq( $output->read, <<'OUT' ); +1..4 +Bail out! ROCKS FALL! EVERYONE DIES! +OUT + +$Test->is_eq( $Exit_Code, 255 ); diff --git a/lib/Test/Simple/t/create.t b/lib/Test/Simple/t/create.t index 7d266d937a..5600d6830a 100644 --- a/lib/Test/Simple/t/create.t +++ b/lib/Test/Simple/t/create.t @@ -16,21 +16,23 @@ use Test::More tests => 8; use Test::Builder; my $more_tb = Test::More->builder; -my $new_tb = Test::Builder->create; - -isa_ok $new_tb, 'Test::Builder'; isa_ok $more_tb, 'Test::Builder'; -isnt $more_tb, $new_tb, 'Test::Builder->create makes a new object'; - is $more_tb, Test::More->builder, 'create does not interfere with ->builder'; is $more_tb, Test::Builder->new, ' does not interfere with ->new'; -$new_tb->output("some_file"); -END { 1 while unlink "some_file" } +{ + my $new_tb = Test::Builder->create; + + isa_ok $new_tb, 'Test::Builder'; + isnt $more_tb, $new_tb, 'Test::Builder->create makes a new object'; -$new_tb->plan(tests => 1); -$new_tb->ok(1); + $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"); diff --git a/lib/Test/Simple/t/eq_set.t b/lib/Test/Simple/t/eq_set.t index 4785507a61..fbdc52db1f 100644 --- a/lib/Test/Simple/t/eq_set.t +++ b/lib/Test/Simple/t/eq_set.t @@ -14,8 +14,21 @@ chdir 't'; use strict; use Test::More; -plan tests => 2; +plan tests => 4; # RT 3747 ok( eq_set([1, 2, [3]], [[3], 1, 2]) ); ok( eq_set([1,2,[3]], [1,[3],2]) ); + +# bugs.perl.org 36354 +my $ref = \2; +ok( eq_set( [$ref, "$ref", "$ref", $ref], + ["$ref", $ref, $ref, "$ref"] + ) ); + +TODO: { + local $TODO = q[eq_set() doesn't really handle references]; + + ok( eq_set( [\1, \2, \3], [\2, \3, \1] ) ); +} + diff --git a/lib/Test/Simple/t/exit.t b/lib/Test/Simple/t/exit.t index 0e30ce707f..6630b645a3 100644 --- a/lib/Test/Simple/t/exit.t +++ b/lib/Test/Simple/t/exit.t @@ -51,8 +51,9 @@ my %Tests = ( 'one_fail.plx' => [1, 4], 'two_fail.plx' => [2, 4], 'five_fail.plx' => [5, 4], - 'extras.plx' => [3, 4], - 'too_few.plx' => [4, 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'], diff --git a/lib/Test/Simple/t/extra.t b/lib/Test/Simple/t/extra.t index 4dceb2cf63..a0058661c4 100644 --- a/lib/Test/Simple/t/extra.t +++ b/lib/Test/Simple/t/extra.t @@ -10,20 +10,11 @@ BEGIN { # 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++; -} +# 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 => 2); package main; @@ -46,7 +37,7 @@ ok(1, 'Car'); ok(0, 'Sar'); END { - My::Test::ok($$out eq <<OUT); + $TB->is_eq($$out, <<OUT); 1..3 ok 1 - Foo not ok 2 - Bar @@ -55,10 +46,13 @@ ok 4 - Car not ok 5 - Sar OUT - My::Test::ok($$err eq <<ERR); -# Failed test ($0 at line 31) -# Failed test ($0 at line 34) + $TB->is_eq($$err, <<ERR); +# Failed test 'Bar' +# in $0 at line 31. +# Failed test 'Sar' +# in $0 at line 34. # Looks like you planned 3 tests but ran 2 extra. +# Looks like you failed 2 tests of 5 run. ERR exit 0; diff --git a/lib/Test/Simple/t/extra_one.t b/lib/Test/Simple/t/extra_one.t index f8dacc614a..30830d3e37 100644 --- a/lib/Test/Simple/t/extra_one.t +++ b/lib/Test/Simple/t/extra_one.t @@ -18,20 +18,13 @@ my($out, $err) = Test::Simple::Catch::caught(); # 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++; -} +# 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 => 2); + +sub is { $TB->is_eq(@_) } package main; @@ -43,14 +36,14 @@ ok(1); ok(1); END { - My::Test::ok($$out eq <<OUT); + My::Test::is($$out, <<OUT); 1..1 ok 1 ok 2 ok 3 OUT - My::Test::ok($$err eq <<ERR); + My::Test::is($$err, <<ERR); # Looks like you planned 1 test but ran 2 extra. ERR diff --git a/lib/Test/Simple/t/fail-like.t b/lib/Test/Simple/t/fail-like.t index 799762f6a6..5631b589d6 100644 --- a/lib/Test/Simple/t/fail-like.t +++ b/lib/Test/Simple/t/fail-like.t @@ -22,28 +22,20 @@ BEGIN { use strict; -require Test::Simple::Catch; -my($out, $err) = Test::Simple::Catch::caught(); -local $ENV{HARNESS_ACTIVE} = 0; - # 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++; -} +# 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 => 2); + + +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); +local $ENV{HARNESS_ACTIVE} = 0; package main; @@ -55,20 +47,21 @@ eval q{ like( "foo", qr/that/, 'is foo like that' ); }; END { - My::Test::ok($$out eq <<OUT, 'failing output'); + $TB->is_eq($$out, <<OUT, 'failing output'); 1..1 not ok 1 - is foo like that OUT my $err_re = <<ERR; -# Failed test \\(.*\\) +# Failed test 'is foo like that' +# in .* at line 1\. # 'foo' # doesn't match '\\(\\?-xism:that\\)' # Looks like you failed 1 test of 1\\. ERR - My::Test::ok($$err =~ /^$err_re$/, 'failing errors'); + $TB->like($$err, qr/^$err_re$/, 'failing errors'); exit(0); } diff --git a/lib/Test/Simple/t/fail-more.t b/lib/Test/Simple/t/fail-more.t index 2086df2bb8..6f9d634c02 100644 --- a/lib/Test/Simple/t/fail-more.t +++ b/lib/Test/Simple/t/fail-more.t @@ -20,53 +20,45 @@ local $ENV{HARNESS_ACTIVE} = 0; # Can't use Test.pm, that's a 5.005 thing. package My::Test; -print "1..12\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++; - - return $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 => 17); + +sub like ($$;$) { + $TB->like(@_); } +sub is ($$;$) { + $TB->is_eq(@_); +} sub main::err_ok ($) { my($expect) = @_; my $got = $err->read; - my $ok = ok( $got eq $expect ); - - unless( $ok ) { - print STDERR "$got\n"; - print STDERR "$expect\n"; - } - - return $ok; + return $TB->is_eq( $got, $expect ); } package main; require Test::More; -my $Total = 29; +my $Total = 28; Test::More->import(tests => $Total); my $tb = Test::More->builder; $tb->use_numbers(0); +my $Filename = quotemeta $0; + # Preserve the line numbers. #line 38 ok( 0, 'failing' ); err_ok( <<ERR ); -# Failed test ($0 at line 38) +# Failed test 'failing' +# in $0 at line 38. ERR #line 40 @@ -75,16 +67,20 @@ is( undef, '', 'undef is empty string?'); is( undef, 0, 'undef is 0?'); is( '', 0, 'empty string is 0?' ); err_ok( <<ERR ); -# Failed test ($0 at line 40) +# Failed test 'foo is bar?' +# in $0 at line 40. # got: 'foo' # expected: 'bar' -# Failed test ($0 at line 41) +# Failed test 'undef is empty string?' +# in $0 at line 41. # got: undef # expected: '' -# Failed test ($0 at line 42) +# Failed test 'undef is 0?' +# in $0 at line 42. # got: undef # expected: '0' -# Failed test ($0 at line 43) +# Failed test 'empty string is 0?' +# in $0 at line 43. # got: '' # expected: '0' ERR @@ -94,15 +90,18 @@ isnt("foo", "foo", 'foo isnt foo?' ); isn't("foo", "foo",'foo isn\'t foo?' ); isnt(undef, undef, 'undef isnt undef?'); err_ok( <<ERR ); -# Failed test ($0 at line 45) +# Failed test 'foo isnt foo?' +# in $0 at line 45. # 'foo' # ne # 'foo' -# Failed test ($0 at line 46) +# Failed test 'foo isn\'t foo?' +# in $0 at line 46. # 'foo' # ne # 'foo' -# Failed test ($0 at line 47) +# Failed test 'undef isnt undef?' +# in $0 at line 47. # undef # ne # undef @@ -112,35 +111,43 @@ ERR like( "foo", '/that/', 'is foo like that' ); unlike( "foo", '/foo/', 'is foo unlike foo' ); err_ok( <<ERR ); -# Failed test ($0 at line 48) +# Failed test 'is foo like that' +# in $0 at line 48. # 'foo' # doesn't match '/that/' -# Failed test ($0 at line 49) +# Failed test 'is foo unlike foo' +# in $0 at line 49. # 'foo' # matches '/foo/' ERR # Nick Clark found this was a bug. Fixed in 0.40. +# line 60 like( "bug", '/(%)/', 'regex with % in it' ); err_ok( <<ERR ); -# Failed test ($0 at line 60) +# Failed test 'regex with % in it' +# in $0 at line 60. # 'bug' # doesn't match '/(%)/' ERR +#line 67 fail('fail()'); err_ok( <<ERR ); -# Failed test ($0 at line 67) +# Failed test 'fail()' +# in $0 at line 67. ERR #line 52 can_ok('Mooble::Hooble::Yooble', qw(this that)); can_ok('Mooble::Hooble::Yooble', ()); err_ok( <<ERR ); -# Failed test ($0 at line 52) +# Failed test 'Mooble::Hooble::Yooble->can(...)' +# in $0 at line 52. # Mooble::Hooble::Yooble->can('this') failed # Mooble::Hooble::Yooble->can('that') failed -# Failed test ($0 at line 53) +# Failed test 'Mooble::Hooble::Yooble->can(...)' +# in $0 at line 53. # can_ok() called with no methods ERR @@ -150,13 +157,17 @@ isa_ok(42, "Wibble", "My Wibble"); isa_ok(undef, "Wibble", "Another Wibble"); isa_ok([], "HASH"); err_ok( <<ERR ); -# Failed test ($0 at line 55) +# Failed test 'The object isa Wibble' +# in $0 at line 55. # The object isn't a 'Wibble' it's a 'Foo' -# Failed test ($0 at line 56) +# Failed test 'My Wibble isa Wibble' +# in $0 at line 56. # My Wibble isn't a reference -# Failed test ($0 at line 57) +# Failed test 'Another Wibble isa Wibble' +# in $0 at line 57. # Another Wibble isn't defined -# Failed test ($0 at line 58) +# Failed test 'The object isa HASH' +# in $0 at line 58. # The object isn't a 'HASH' it's a 'ARRAY' ERR @@ -165,35 +176,56 @@ cmp_ok( 'foo', 'eq', 'bar', 'cmp_ok eq' ); cmp_ok( 42.1, '==', 23, , ' ==' ); cmp_ok( 42, '!=', 42 , ' !=' ); cmp_ok( 1, '&&', 0 , ' &&' ); -cmp_ok( 42, '==', "foo", ' == with strings' ); -cmp_ok( 42, 'eq', "foo", ' eq with numbers' ); -cmp_ok( undef, 'eq', 'foo', ' eq with undef' ); err_ok( <<ERR ); -# Failed test ($0 at line 68) +# Failed test 'cmp_ok eq' +# in $0 at line 68. # got: 'foo' # expected: 'bar' -# Failed test ($0 at line 69) +# Failed test ' ==' +# in $0 at line 69. # got: 42.1 # expected: 23 -# Failed test ($0 at line 70) +# Failed test ' !=' +# in $0 at line 70. # '42' # != # '42' -# Failed test ($0 at line 71) +# Failed test ' &&' +# in $0 at line 71. # '1' # && # '0' -# Failed test ($0 at line 72) -# got: 42 -# expected: 0 -# Failed test ($0 at line 73) +ERR + + +# line 196 +cmp_ok( 42, 'eq', "foo", ' eq with numbers' ); +err_ok( <<ERR ); +# Failed test ' eq with numbers' +# in $0 at line 196. # got: '42' # expected: 'foo' -# Failed test ($0 at line 74) -# got: undef -# expected: 'foo' ERR + +{ + my $warnings; + local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; + +# line 211 + cmp_ok( 42, '==', "foo", ' == with strings' ); + err_ok( <<ERR ); +# Failed test ' == with strings' +# in $0 at line 211. +# got: 42 +# expected: foo +ERR + My::Test::like $warnings, + qq[/^Argument "foo" isn't numeric in .* at $Filename line 211\\\.\n\$/]; + +} + + # generate a $!, it changes its value by context. -e "wibblehibble"; my $Errno_Number = $!+0; @@ -202,21 +234,45 @@ my $Errno_String = $!.''; cmp_ok( $!, 'eq', '', ' eq with stringified errno' ); cmp_ok( $!, '==', -1, ' eq with numerified errno' ); err_ok( <<ERR ); -# Failed test ($0 at line 80) +# Failed test ' eq with stringified errno' +# in $0 at line 80. # got: '$Errno_String' # expected: '' -# Failed test ($0 at line 81) +# Failed test ' eq with numerified errno' +# in $0 at line 81. # got: $Errno_Number # expected: -1 ERR #line 84 use_ok('Hooble::mooble::yooble'); + +my $more_err_re = <<ERR; +# Failed test 'use Hooble::mooble::yooble;' +# in $Filename at line 84\\. +# Tried to use 'Hooble::mooble::yooble'. +# Error: Can't locate Hooble.* in \\\@INC .* +# BEGIN failed--compilation aborted at $Filename line 84. +ERR + +My::Test::like($err->read, "/^$more_err_re/"); + + +#line 85 require_ok('ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble'); +$more_err_re = <<ERR; +# Failed test 'require ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble;' +# in $Filename at line 85\\. +# Tried to require 'ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble'. +# Error: Can't locate ALL.* in \\\@INC .* +ERR + +My::Test::like($err->read, "/^$more_err_re/"); + #line 88 END { - My::Test::ok($$out eq <<OUT, 'failing output'); + $TB->is_eq($$out, <<OUT, 'failing output'); 1..$Total not ok - failing not ok - foo is bar? @@ -240,33 +296,17 @@ not ok - cmp_ok eq not ok - == not ok - != not ok - && -not ok - == with strings not ok - eq with numbers -not ok - eq with undef +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 - my $filename = quotemeta $0; - my $more_err_re = <<ERR; -# Failed test \\($filename at line 84\\) -# Tried to use 'Hooble::mooble::yooble'. -# Error: Can't locate Hooble.* in \\\@INC .* -# BEGIN failed--compilation aborted at $filename line 84. -# Failed test \\($filename at line 85\\) -# Tried to require 'ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble'. -# Error: Can't locate ALL.* in \\\@INC .* +err_ok( <<ERR ); # Looks like you failed $Total tests of $Total. ERR - unless( My::Test::ok($$err =~ /^$more_err_re$/, - 'failing errors') ) { - print $$err; - print "regex:\n"; - print $more_err_re; - } - exit(0); } diff --git a/lib/Test/Simple/t/fail.t b/lib/Test/Simple/t/fail.t index 30a107b6cb..822fcb8c70 100644 --- a/lib/Test/Simple/t/fail.t +++ b/lib/Test/Simple/t/fail.t @@ -60,8 +60,10 @@ not ok 5 - damnit OUT My::Test::ok($$err eq <<ERR); -# Failed test ($0 at line 38) -# Failed test ($0 at line 39) +# Failed test 'oh no!' +# in $0 at line 38. +# Failed test 'damnit' +# in $0 at line 39. # Looks like you failed 2 tests of 5. ERR diff --git a/lib/Test/Simple/t/fail_one.t b/lib/Test/Simple/t/fail_one.t index d379a77d23..fe22624741 100644 --- a/lib/Test/Simple/t/fail_one.t +++ b/lib/Test/Simple/t/fail_one.t @@ -53,7 +53,7 @@ not ok 1 OUT My::Test::ok($$err eq <<ERR) || print $$err; -# Failed test ($0 at line 45) +# Failed test in $0 at line 45. # Looks like you failed 1 test of 1. ERR diff --git a/lib/Test/Simple/t/harness_active.t b/lib/Test/Simple/t/harness_active.t index fac5a7fd08..d3ae56a828 100644 --- a/lib/Test/Simple/t/harness_active.t +++ b/lib/Test/Simple/t/harness_active.t @@ -19,21 +19,15 @@ my($out, $err) = Test::Simple::Catch::caught(); # Can't use Test.pm, that's a 5.005 thing. package My::Test; -print "1..4\n"; +# 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 => 4); -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; + return $TB->ok(@_); } @@ -41,14 +35,7 @@ sub main::err_ok ($) { my($expect) = @_; my $got = $err->read; - my $ok = ok( $got eq $expect ); - - unless( $ok ) { - print STDERR "got\n$got\n"; - print STDERR "expected\n$expect\n"; - } - - return $ok; + return $TB->is_eq( $got, $expect ); } @@ -64,13 +51,14 @@ Test::More->builder->no_ending(1); #line 62 fail( "this fails" ); err_ok( <<ERR ); -# Failed test ($0 at line 62) +# Failed test 'this fails' +# in $0 at line 62. ERR #line 72 is( 1, 0 ); err_ok( <<ERR ); -# Failed test ($0 at line 72) +# Failed test in $0 at line 72. # got: '1' # expected: '0' ERR @@ -83,7 +71,8 @@ ERR fail( "this fails" ); err_ok( <<ERR ); -# Failed test ($0 at line 71) +# Failed test 'this fails' +# in $0 at line 71. ERR @@ -91,7 +80,7 @@ ERR is( 1, 0 ); err_ok( <<ERR ); -# Failed test ($0 at line 84) +# Failed test in $0 at line 84. # got: '1' # expected: '0' ERR diff --git a/lib/Test/Simple/t/has_plan2.t b/lib/Test/Simple/t/has_plan2.t index 33e0923ff6..e13ea4af94 100644 --- a/lib/Test/Simple/t/has_plan2.t +++ b/lib/Test/Simple/t/has_plan2.t @@ -15,18 +15,6 @@ BEGIN { } } -BEGIN { - require Test::Harness; -} - -# This feature requires a fairly new version of Test::Harness -if( $Test::Harness::VERSION < 2.03 ) { - plan tests => 1; - diag "Need Test::Harness 2.03 or up. You have $Test::Harness::VERSION."; - fail 'Need Test::Harness 2.03 or up'; - exit; -} - use strict; use Test::Builder; diff --git a/lib/Test/Simple/t/is_deeply_fail.t b/lib/Test/Simple/t/is_deeply_fail.t index ed61ee847f..48f3828b06 100644 --- a/lib/Test/Simple/t/is_deeply_fail.t +++ b/lib/Test/Simple/t/is_deeply_fail.t @@ -44,7 +44,7 @@ sub is ($$;$) { sub like ($$;$) { my($this, $regex, $name) = @_; - $regex = qr/$regex/ unless ref $regex; + $regex = "/$regex/" if !ref $regex and $regex !~ m{^/.*/$}s; my $ok = $TB->like($$this, $regex, $name); @@ -63,7 +63,8 @@ my $Filename = quotemeta $0; ok !is_deeply('foo', 'bar', 'plain strings'); is( $out, "not ok 1 - plain strings\n", 'plain strings' ); is( $err, <<ERR, ' right diagnostic' ); -# Failed test ($0 at line 68) +# Failed test 'plain strings' +# in $0 at line 68. # got: 'foo' # expected: 'bar' ERR @@ -73,7 +74,8 @@ ERR ok !is_deeply({}, [], 'different types'); is( $out, "not ok 2 - different types\n", 'different types' ); like( $err, <<ERR, ' right diagnostic' ); -# Failed test \\($Filename at line 78\\) +# Failed test 'different types' +# in $Filename at line 78. # Structures begin differing at: # \\\$got = HASH\\(0x[0-9a-f]+\\) # \\\$expected = ARRAY\\(0x[0-9a-f]+\\) @@ -84,7 +86,8 @@ ok !is_deeply({ this => 42 }, { this => 43 }, 'hashes with different values'); is( $out, "not ok 3 - hashes with different values\n", 'hashes with different values' ); is( $err, <<ERR, ' right diagnostic' ); -# Failed test ($0 at line 88) +# Failed test 'hashes with different values' +# in $0 at line 88. # Structures begin differing at: # \$got->{this} = '42' # \$expected->{this} = '43' @@ -95,7 +98,8 @@ ok !is_deeply({ that => 42 }, { this => 42 }, 'hashes with different keys'); is( $out, "not ok 4 - hashes with different keys\n", 'hashes with different keys' ); is( $err, <<ERR, ' right diagnostic' ); -# Failed test ($0 at line 99) +# Failed test 'hashes with different keys' +# in $0 at line 99. # Structures begin differing at: # \$got->{this} = Does not exist # \$expected->{this} = '42' @@ -106,7 +110,8 @@ ok !is_deeply([1..9], [1..10], 'arrays of different length'); is( $out, "not ok 5 - arrays of different length\n", 'arrays of different length' ); is( $err, <<ERR, ' right diagnostic' ); -# Failed test ($0 at line 110) +# Failed test 'arrays of different length' +# in $0 at line 110. # Structures begin differing at: # \$got->[9] = Does not exist # \$expected->[9] = '10' @@ -116,7 +121,8 @@ ERR ok !is_deeply([undef, undef], [undef], 'arrays of undefs' ); is( $out, "not ok 6 - arrays of undefs\n", 'arrays of undefs' ); is( $err, <<ERR, ' right diagnostic' ); -# Failed test ($0 at line 121) +# Failed test 'arrays of undefs' +# in $0 at line 121. # Structures begin differing at: # \$got->[1] = undef # \$expected->[1] = Does not exist @@ -126,7 +132,8 @@ ERR ok !is_deeply({ foo => undef }, {}, 'hashes of undefs' ); is( $out, "not ok 7 - hashes of undefs\n", 'hashes of undefs' ); is( $err, <<ERR, ' right diagnostic' ); -# Failed test ($0 at line 131) +# Failed test 'hashes of undefs' +# in $0 at line 131. # Structures begin differing at: # \$got->{foo} = undef # \$expected->{foo} = Does not exist @@ -136,7 +143,8 @@ ERR ok !is_deeply(\42, \23, 'scalar refs'); is( $out, "not ok 8 - scalar refs\n", 'scalar refs' ); is( $err, <<ERR, ' right diagnostic' ); -# Failed test ($0 at line 141) +# Failed test 'scalar refs' +# in $0 at line 141. # Structures begin differing at: # \${ \$got} = '42' # \${\$expected} = '23' @@ -147,7 +155,8 @@ ok !is_deeply([], \23, 'mixed scalar and array refs'); is( $out, "not ok 9 - mixed scalar and array refs\n", 'mixed scalar and array refs' ); like( $err, <<ERR, ' right diagnostic' ); -# Failed test \\($Filename at line 151\\) +# Failed test 'mixed scalar and array refs' +# in $Filename at line 151. # Structures begin differing at: # \\\$got = ARRAY\\(0x[0-9a-f]+\\) # \\\$expected = SCALAR\\(0x[0-9a-f]+\\) @@ -166,7 +175,8 @@ $b3 = 23; ok !is_deeply($a1, $b1, 'deep scalar refs'); is( $out, "not ok 10 - deep scalar refs\n", 'deep scalar refs' ); is( $err, <<ERR, ' right diagnostic' ); -# Failed test ($0 at line 173) +# Failed test 'deep scalar refs' +# in $0 at line 173. # Structures begin differing at: # \${\${ \$got}} = '42' # \${\${\$expected}} = '23' @@ -192,7 +202,8 @@ ok !is_deeply( $foo, $bar, 'deep structures' ); ok( @Test::More::Data_Stack == 0, '@Data_Stack not holding onto things' ); is( $out, "not ok 11 - deep structures\n", 'deep structures' ); is( $err, <<ERR, ' right diagnostic' ); -# Failed test ($0 at line 198) +# Failed test 'deep structures' +# in $0 at line 198. # Structures begin differing at: # \$got->{that}{foo} = Does not exist # \$expected->{that}{foo} = '42' @@ -213,7 +224,7 @@ foreach my $test (@tests) { ok !is_deeply(@$test); like \$warning, - qr/^is_deeply\(\) takes two or three args, you gave $num_args\.\n/; + "/^is_deeply\\(\\) takes two or three args, you gave $num_args\.\n/"; } @@ -241,7 +252,7 @@ $$err = $$out = ''; ok !is_deeply( [\'a', 'b'], [\'a', 'c'] ); is( $out, "not ok 20\n", 'scalar refs in an array' ); is( $err, <<ERR, ' right diagnostic' ); -# Failed test ($0 at line 274) +# Failed test in $0 at line 274. # Structures begin differing at: # \$got->[1] = 'b' # \$expected->[1] = 'c' @@ -253,7 +264,7 @@ my $ref = \23; ok !is_deeply( 23, $ref ); is( $out, "not ok 21\n", 'scalar vs ref' ); is( $err, <<ERR, ' right diagnostic'); -# Failed test ($0 at line 286) +# Failed test in $0 at line 286. # Structures begin differing at: # \$got = '23' # \$expected = $ref @@ -263,7 +274,7 @@ ERR ok !is_deeply( $ref, 23 ); is( $out, "not ok 22\n", 'ref vs scalar' ); is( $err, <<ERR, ' right diagnostic'); -# Failed test ($0 at line 296) +# Failed test in $0 at line 296. # Structures begin differing at: # \$got = $ref # \$expected = '23' @@ -273,7 +284,7 @@ ERR ok !is_deeply( undef, [] ); is( $out, "not ok 23\n", 'is_deeply and undef [RT 9441]' ); like( $err, <<ERR, ' right diagnostic' ); -# Failed test \\($Filename at line 306\\) +# Failed test in $Filename at line 306\\. # Structures begin differing at: # \\\$got = undef # \\\$expected = ARRAY\\(0x[0-9a-f]+\\) @@ -289,7 +300,7 @@ ERR ok !is_deeply( $array, $hash ); is( $out, "not ok 24\n", 'is_deeply and different reference types' ); is( $err, <<ERR, ' right diagnostic' ); -# Failed test ($0 at line 321) +# Failed test in $0 at line 321. # Structures begin differing at: # \$got = $array # \$expected = $hash @@ -299,7 +310,7 @@ ERR ok !is_deeply( [$array], [$hash] ); is( $out, "not ok 25\n", 'nested different ref types' ); is( $err, <<ERR, ' right diagnostic' ); -# Failed test ($0 at line 332) +# Failed test in $0 at line 332. # Structures begin differing at: # \$got->[0] = $array # \$expected->[0] = $hash @@ -312,14 +323,14 @@ ERR { package Bar; - overload->import(q[""] => sub { "wibble" }); + "overload"->import(q[""] => sub { "wibble" }); } #line 353 ok !is_deeply( [$foo], [$bar] ); is( $out, "not ok 26\n", 'string overloaded refs respected in diag' ); is( $err, <<ERR, ' right diagnostic' ); -# Failed test ($0 at line 353) +# Failed test in $0 at line 353. # Structures begin differing at: # \$got->[0] = $foo # \$expected->[0] = 'wibble' diff --git a/lib/Test/Simple/t/missing.t b/lib/Test/Simple/t/missing.t index f8a4581c6e..e57cace508 100644 --- a/lib/Test/Simple/t/missing.t +++ b/lib/Test/Simple/t/missing.t @@ -11,20 +11,13 @@ BEGIN { # 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++; -} +# 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 => 2); + +sub is { $TB->is_eq(@_) } package main; @@ -42,15 +35,17 @@ ok(1, 'Foo'); ok(0, 'Bar'); END { - My::Test::ok($$out eq <<OUT); + My::Test::is($$out, <<OUT); 1..5 ok 1 - Foo not ok 2 - Bar OUT - My::Test::ok($$err eq <<ERR); -# Failed test ($0 at line 31) + My::Test::is($$err, <<ERR); +# Failed test 'Bar' +# in $0 at line 31. # Looks like you planned 5 tests but only ran 2. +# Looks like you failed 1 test of 2 run. ERR exit 0; diff --git a/lib/Test/Simple/t/no_diag.t b/lib/Test/Simple/t/no_diag.t index 21ecd03192..6fa538a82e 100644 --- a/lib/Test/Simple/t/no_diag.t +++ b/lib/Test/Simple/t/no_diag.t @@ -1,6 +1,8 @@ #!/usr/bin/perl -w -use Test::More 'no_diag', tests => 1; +use Test::More 'no_diag', tests => 2; pass('foo'); diag('This should not be displayed'); + +is(Test::More->builder->no_diag, 1); diff --git a/lib/Test/Simple/t/overload.t b/lib/Test/Simple/t/overload.t index 18e7c3d5f4..e0e70d4229 100644 --- a/lib/Test/Simple/t/overload.t +++ b/lib/Test/Simple/t/overload.t @@ -18,7 +18,7 @@ BEGIN { plan skip_all => "needs overload.pm"; } else { - plan tests => 7; + plan tests => 13; } } @@ -27,8 +27,7 @@ package Overloaded; use overload q{""} => sub { $_[0]->{string} }, - q{0} => sub { $_[0]->{num} }, - fallback => 1; + q{0+} => sub { $_[0]->{num} }; sub new { my $class = shift; @@ -43,8 +42,27 @@ isa_ok $obj, 'Overloaded'; is $obj, 'foo', 'is() with string overloading'; cmp_ok $obj, 'eq', 'foo', 'cmp_ok() ...'; -cmp_ok $obj, '==', 'foo', 'cmp_ok() with number overloading'; +cmp_ok $obj, '==', 42, 'cmp_ok() with number overloading'; is_deeply [$obj], ['foo'], 'is_deeply with string overloading'; ok eq_array([$obj], ['foo']), 'eq_array ...'; ok eq_hash({foo => $obj}, {foo => 'foo'}), 'eq_hash ...'; + +# rt.cpan.org 13506 +is_deeply $obj, 'foo', 'is_deeply with string overloading at the top'; + +Test::More->builder->is_num($obj, 42); +Test::More->builder->is_eq ($obj, "foo"); + + +{ + # rt.cpan.org 14675 + package TestPackage; + use overload q{""} => sub { ::fail("This should not be called") }; + + package Foo; + ::is_deeply(['TestPackage'], ['TestPackage']); + ::is_deeply({'TestPackage' => 'TestPackage'}, + {'TestPackage' => 'TestPackage'}); + ::is_deeply('TestPackage', 'TestPackage'); +} diff --git a/lib/Test/Simple/t/plan_no_plan.t b/lib/Test/Simple/t/plan_no_plan.t index 8c4492ab95..3111592e97 100644 --- a/lib/Test/Simple/t/plan_no_plan.t +++ b/lib/Test/Simple/t/plan_no_plan.t @@ -13,18 +13,6 @@ BEGIN { } } -BEGIN { - require Test::Harness; -} - -# This feature requires a fairly new version of Test::Harness -if( $Test::Harness::VERSION < 2.03 ) { - plan tests => 1; - diag "Need Test::Harness 2.03 or up. You have $Test::Harness::VERSION."; - fail 'Need Test::Harness 2.03 or up'; - exit; -} - plan 'no_plan'; pass('Just testing'); diff --git a/lib/Test/Simple/t/todo.t b/lib/Test/Simple/t/todo.t index 14a7b001f5..3e5ad02c34 100644 --- a/lib/Test/Simple/t/todo.t +++ b/lib/Test/Simple/t/todo.t @@ -7,20 +7,8 @@ BEGIN { } } -require Test::Harness; use Test::More; -# 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 => 18; diff --git a/lib/Test/Simple/t/undef.t b/lib/Test/Simple/t/undef.t index e9180bb447..7afb2a6464 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 => 16; +use Test::More tests => 18; use TieOut; BEGIN { $^W = 1; } @@ -19,32 +19,59 @@ BEGIN { $^W = 1; } my $warnings = ''; local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; +my $TB = Test::Builder->new; +sub no_warnings { + $TB->is_eq($warnings, '', ' no warnings'); + $warnings = ''; +} + +sub warnings_is { + $TB->is_eq($warnings, $_[0]); + $warnings = ''; +} + +sub warnings_like { + $TB->like($warnings, "/$_[0]/"); + $warnings = ''; +} + + +my $Filename = quotemeta $0; + + is( undef, undef, 'undef is undef'); -is( $warnings, '', ' no warnings' ); +no_warnings; isnt( undef, 'foo', 'undef isnt foo'); -is( $warnings, '', ' no warnings' ); +no_warnings; isnt( undef, '', 'undef isnt an empty string' ); isnt( undef, 0, 'undef isnt zero' ); +#line 45 like( undef, '/.*/', 'undef is like anything' ); -is( $warnings, '', ' no warnings' ); +warnings_like("Use of uninitialized value.* at $Filename line 45\\.\n"); eq_array( [undef, undef], [undef, 23] ); -is( $warnings, '', 'eq_array() no warnings' ); +no_warnings; eq_hash ( { foo => undef, bar => undef }, { foo => undef, bar => 23 } ); -is( $warnings, '', 'eq_hash() no warnings' ); +no_warnings; eq_set ( [undef, undef, 12], [29, undef, undef] ); -is( $warnings, '', 'eq_set() no warnings' ); +no_warnings; eq_hash ( { foo => undef, bar => { baz => undef, moo => 23 } }, { foo => undef, bar => { baz => undef, moo => 23 } } ); -is( $warnings, '', 'eq_hash() no warnings' ); +no_warnings; + + +#line 64 +cmp_ok( undef, '<=', 2, ' undef <= 2' ); +warnings_like("Use of uninitialized value.* at $Filename line 64\\.\n"); + my $tb = Test::More->builder; @@ -57,9 +84,9 @@ diag(undef); $tb->failure_output($old_fail); is( $caught->read, "# undef\n" ); -is( $warnings, '', 'diag(undef) no warnings' ); +no_warnings; $tb->maybe_regex(undef); is( $caught->read, '' ); -is( $warnings, '', 'maybe_regex(undef) no warnings' ); +no_warnings; |