From: Rafael Garcia-Suarez Date: Mon, 26 Sep 2005 16:31:43 +0000 (+0000) Subject: Upgrade to Test::Simple 0.61 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b1ddf169801254979af17f682f37e96143b35982;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Test::Simple 0.61 p4raw-id: //depot/perl@25604 --- diff --git a/MANIFEST b/MANIFEST index 36f94d8..755e4b3 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1926,6 +1926,7 @@ lib/Term/Complete.t See if Term::Complete works lib/Term/ReadLine.pm Stub readline library lib/Term/ReadLine.t See if Term::ReadLine works lib/Test/Builder.pm For writing new test libraries +lib/Test/Builder/Module.pm Base class for test modules lib/Test/Harness/Assert.pm Test::Harness::Assert (internal use only) lib/Test/Harness/bin/prove The prove harness utility lib/Test/Harness/Changes Test::Harness @@ -1959,6 +1960,7 @@ lib/Test/Simple.pm Basic utility for writing tests 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/buffer.t Test::Builder buffering test lib/Test/Simple/t/Builder.t Test::Builder tests lib/Test/Simple/t/circular_data.t Test::Simple test @@ -2772,6 +2774,7 @@ t/lib/Test/Simple/sample_tests/pre_plan_death.plx for exit.t t/lib/Test/Simple/sample_tests/require.plx for exit.t t/lib/Test/Simple/sample_tests/success.plx for exit.t t/lib/Test/Simple/sample_tests/too_few.plx for exit.t +t/lib/Test/Simple/sample_tests/too_few_fail.plx for exit.t t/lib/Test/Simple/sample_tests/two_fail.plx for exit.t t/lib/TieIn.pm Testing library for dummy input handles t/lib/TieOut.pm Testing library to capture prints diff --git a/lib/Test/Builder.pm b/lib/Test/Builder.pm index 859915b..b107633 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(<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 $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 - $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 + + $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 $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 - $Test->no_header($no_header); +=item B -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 @@ -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 + + $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 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 0000000..b3ccce6 --- /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 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[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 This mechanism is I 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 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 3183a60..c305dd0 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: using no_plan requires a Test::Harness upgrade else it will -think everything has failed. See L) +think everything has failed. See L). 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 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 @@ -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 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. - -=over 4 - -=item B - - diag(@diagnostic_message); - -Prints a diagnostic message which is guaranteed not to interfere with -test output. Like C @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 with the mnemonic C. - -All diag()s can be made silent by passing the "no_diag" option to -Test::More. C 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 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(<diag(<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(<diag(< I'm not quite sure what will happen with filehandles. + +=over 4 + +=item B + + 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 = <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. + +=over 4 + +=item B + + diag(@diagnostic_message); + +Prints a diagnostic message which is guaranteed not to interfere with +test output. Like C @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 with the mnemonic C. + +B 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: TODO tests require a Test::Harness upgrade else it will -treat it as a normal failure. See L) +treat it as a normal failure. See L). =item B @@ -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 I'm not quite sure what will happen with filehandles. +=head2 Test control =over 4 -=item B +=item B - 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 = <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 can do that better and with diagnostics. They may be deprecated in future versions. +=over 4 =item B @@ -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 By historical accident, this is not a true set comparison. While the order of elements does not matter, duplicate elements do. +B 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. 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 (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 f84ac5e..74cb1fc 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 d046129..2f44ab6 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 7a290f4..d50c8b5 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 <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 7d266d9..5600d68 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 4785507..fbdc52d 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 0e30ce7..6630b64 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 4dceb2c..a005866 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 <is_eq($$out, <is_eq($$err, <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 <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 <is_eq($$out, <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 2086df2..6f9d634 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( <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( <read, "/^$more_err_re/"); + + +#line 85 require_ok('ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble'); +$more_err_re = <read, "/^$more_err_re/"); + #line 88 END { - My::Test::ok($$out eq <is_eq($$out, <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( < 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 ed61ee8..48f3828 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, < 42 }, { this => 43 }, 'hashes with different values'); is( $out, "not ok 3 - hashes with different values\n", 'hashes with different values' ); is( $err, <{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, <{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, <[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, <[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, <{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, <{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, <[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, <[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, <[0] = $foo # \$expected->[0] = 'wibble' diff --git a/lib/Test/Simple/t/missing.t b/lib/Test/Simple/t/missing.t index f8a4581..e57cace 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 < 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 18e7c3d..e0e70d4 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 8c4492a..3111592 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 14a7b00..3e5ad02 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 e9180bb..7afb2a6 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; diff --git a/t/lib/Test/Simple/sample_tests/too_few.plx b/t/lib/Test/Simple/sample_tests/too_few.plx index 95af8e9..bbc630d 100644 --- a/t/lib/Test/Simple/sample_tests/too_few.plx +++ b/t/lib/Test/Simple/sample_tests/too_few.plx @@ -8,4 +8,4 @@ Test::Simple->import(tests => 5); ok(1); -ok(0); +ok(1); diff --git a/t/lib/Test/Simple/sample_tests/too_few_fail.plx b/t/lib/Test/Simple/sample_tests/too_few_fail.plx new file mode 100644 index 0000000..5910e13 --- /dev/null +++ b/t/lib/Test/Simple/sample_tests/too_few_fail.plx @@ -0,0 +1,12 @@ +require Test::Simple; + +push @INC, 't/lib'; +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); + +Test::Simple->import(tests => 5); + + +ok(0); +ok(1); +ok(0); \ No newline at end of file