From: Michael G. Schwern Date: Thu, 25 Apr 2002 01:32:10 +0000 (-0400) Subject: Test::Simple/More/Builder 0.42 -> 0.44 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=89c1e84a8ddee4e72c2d00b6fe3904935a07b017;p=p5sagit%2Fp5-mst-13.2.git Test::Simple/More/Builder 0.42 -> 0.44 Message-ID: <20020425053210.GA3334@blackrider> p4raw-id: //depot/perl@16154 --- diff --git a/MANIFEST b/MANIFEST index d15f08b..f48cccf 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1427,6 +1427,7 @@ lib/Test/Simple/Changes Test::Simple changes lib/Test/Simple/README Test::Simple README lib/Test/Simple/t/buffer.t Test::Builder buffering test lib/Test/Simple/t/Builder.t Test::Builder tests +lib/Test/Simple/t/curr_test.t Test::Builder->curr_test tests lib/Test/Simple/t/diag.t Test::More diag() test lib/Test/Simple/t/exit.t Test::Simple test, exit codes lib/Test/Simple/t/extra.t Test::Simple test @@ -1436,6 +1437,7 @@ lib/Test/Simple/t/fail.t Test::Simple test, test failures lib/Test/Simple/t/filehandles.t Test::Simple test, STDOUT can be played with lib/Test/Simple/t/import.t Test::More test, importing functions lib/Test/Simple/t/is_deeply.t Test::More test, is_deeply() +lib/Test/Simple/t/maybe_regex.t Test::Builder->maybe_regex() tests lib/Test/Simple/t/missing.t Test::Simple test, missing tests lib/Test/Simple/t/More.t Test::More test, basic stuff lib/Test/Simple/t/no_ending.t Test::Builder test, no_ending() @@ -1449,6 +1451,7 @@ lib/Test/Simple/t/plan_skip_all.t Test::More test, plan() w/skip_all lib/Test/Simple/t/simple.t Test::Simple test, basic stuff lib/Test/Simple/t/skip.t Test::More test, SKIP tests lib/Test/Simple/t/skipall.t Test::More test, skip all tests +lib/Test/Simple/t/strays.t Test::Builder stray newline checks lib/Test/Simple/t/todo.t Test::More test, TODO tests lib/Test/Simple/t/undef.t Test::More test, undefs don't cause warnings lib/Test/Simple/t/useing.t Test::More test, compile test diff --git a/lib/Test/Builder.pm b/lib/Test/Builder.pm index da63506..7c710bf 100644 --- a/lib/Test/Builder.pm +++ b/lib/Test/Builder.pm @@ -8,7 +8,7 @@ $^C ||= 0; use strict; use vars qw($VERSION $CLASS); -$VERSION = '0.12'; +$VERSION = '0.14'; $CLASS = __PACKAGE__; my $IsVMS = $^O eq 'VMS'; @@ -55,9 +55,6 @@ Test::Builder - Backend for building test libraries =head1 DESCRIPTION -I Meaning the underlying code is well -tested, yet the interface is subject to change. - Test::Simple and Test::More have proven to be popular testing modules, but they're not always flexible enough. Test::Builder provides the a building block upon which to write your own test libraries I @@ -239,7 +242,8 @@ sub ok { my($self, $test, $name) = @_; unless( $Have_Plan ) { - die "You tried to run a test without a plan! Gotta have a plan.\n"; + require Carp; + Carp::croak("You tried to run a test without a plan! Gotta have a plan."); } $Curr_Test++; @@ -354,7 +358,7 @@ sub _is_diag { } } - $self->diag(sprintf <diag(sprintf <_regex_ok($this, $regex, '!~', $name); } -sub _regex_ok { - my($self, $this, $regex, $cmp, $name) = @_; +=item B - local $Level = $Level + 1; + $Test->maybe_regex(qr/$regex/); + $Test->maybe_regex('/$regex/'); - my $ok = 0; - my $usable_regex; +Convenience method for building testing functions that take regular +expressions as arguments, but need to work before perl 5.005. + +Takes a quoted regular expression produced by qr//, or a string +representing a regular expression. + +Returns a Perl value which may be used instead of the corresponding +regular expression, or undef if it's argument is not recognised. + +For example, a version of like(), sans the useful diagnostic messages, +could be written as: + + sub laconic_like { + my ($self, $this, $regex, $name) = @_; + my $usable_regex = $self->maybe_regex($regex); + die "expecting regex, found '$regex'\n" + unless $usable_regex; + $self->ok($this =~ m/$usable_regex/, $name); + } + +=cut + + +sub maybe_regex { + my ($self, $regex) = @_; + my $usable_regex = undef; if( ref $regex eq 'Regexp' ) { $usable_regex = $regex; } # Check if it looks like '/foo/' elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) { - $usable_regex = "(?$opts)$re"; - } - else { - $ok = $self->ok( 0, $name ); + $usable_regex = length $opts ? "(?$opts)$re" : $re; + }; + return($usable_regex) +}; - $self->diag(" '$regex' doesn't look much like a regex to me."); +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) { + $ok = $self->ok( 0, $name ); + $self->diag(" '$regex' doesn't look much like a regex to me."); return $ok; } @@ -524,7 +560,7 @@ sub _cmp_diag { $got = defined $got ? "'$got'" : 'undef'; $expect = defined $expect ? "'$expect'" : 'undef'; - $self->diag(sprintf <diag(sprintf <use_numbers; - $out .= " # TODO $why\n"; + $out .= " # TODO & SKIP $why\n"; $Test->_print($out); @@ -765,6 +803,14 @@ already. We encourage using this rather than calling print directly. +Returns false. Why? Because diag() is often used in conjunction with +a failing test (C) it "passes through" the failure. + + return ok(...) || diag(...); + +=for blame transfer +Mark Fowler + =cut sub diag { @@ -776,6 +822,7 @@ sub diag { # Escape each line with a #. foreach (@msgs) { + $_ = 'undef' unless defined; s/^/# /gms; } @@ -785,6 +832,8 @@ sub diag { my $fh = $self->todo ? $self->todo_output : $self->failure_output; local($\, $", $,) = (undef, ' ', ''); print $fh @msgs; + + return 0; } =begin _private @@ -808,6 +857,15 @@ sub _print { local($\, $", $,) = (undef, ' ', ''); my $fh = $self->output; + + # Escape each line after the first with a # so we don't + # confuse Test::Harness. + foreach (@msgs) { + s/\n(.)/\n# $1/sg; + } + + push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; + print $fh @msgs; } @@ -933,9 +991,16 @@ sub current_test { my($self, $num) = @_; if( defined $num ) { + + unless( $Have_Plan ) { + require Carp; + Carp::croak("Can't change the current test number without a plan!"); + } + $Curr_Test = $num; if( $num > @Test_Results ) { - for ($#Test_Results..$num-1) { + my $start = @Test_Results ? $#Test_Results : 0; + for ($start..$num-1) { $Test_Results[$_] = 1; } } diff --git a/lib/Test/More.pm b/lib/Test/More.pm index c335187..b97f967 100644 --- a/lib/Test/More.pm +++ b/lib/Test/More.pm @@ -18,7 +18,7 @@ sub _carp { require Exporter; use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); -$VERSION = '0.42'; +$VERSION = '0.44'; @ISA = qw(Exporter); @EXPORT = qw(ok use_ok require_ok is isnt like unlike is_deeply @@ -176,16 +176,18 @@ sub plan { my $caller = caller; $Test->exported_to($caller); - $Test->plan(@plan); my @imports = (); foreach my $idx (0..$#plan) { if( $plan[$idx] eq 'import' ) { - @imports = @{$plan[$idx+1]}; + my($tag, $imports) = splice @plan, $idx, 2; + @imports = @$imports; last; } } + $Test->plan(@plan); + __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); } @@ -455,7 +457,7 @@ as one test. If you desire otherwise, use: sub can_ok ($@) { my($proto, @methods) = @_; - my $class= ref $proto || $proto; + my $class = ref $proto || $proto; unless( @methods ) { my $ok = $Test->ok( 0, "$class->can(...)" ); @@ -465,10 +467,9 @@ sub can_ok ($@) { my @nok = (); foreach my $method (@methods) { - my $test = "'$class'->can('$method')"; local($!, $@); # don't interfere with caller's $@ # eval sometimes resets $! - eval $test || push @nok, $method; + eval { $proto->can($method) } || push @nok, $method; } my $name; @@ -645,7 +646,7 @@ C and C. BEGIN { use_ok($module, @imports); } These simply use the given $module and test to make sure the load -happened ok. It is recommended that you run use_ok() inside a BEGIN +happened ok. It's recommended that you run use_ok() inside a BEGIN block so its functions are exported at compile-time and prototypes are properly honored. @@ -670,7 +671,7 @@ sub use_ok ($;@) { eval <import(\@imports); +'$module'->import(\@imports); USE my $ok = $Test->ok( !$@, "use $module;" ); @@ -764,12 +765,12 @@ easiest way to illustrate: If pigs cannot fly, the whole block of tests will be skipped completely. Test::More will output special ok's which Test::Harness -interprets as skipped tests. It is important to include $how_many tests +interprets as skipped tests. It's important to include $how_many tests are in the block so the total number of tests comes out right (unless you're using C, in which case you can leave $how_many off if you like). -It is perfectly safe to nest SKIP blocks. +It's perfectly safe to nest SKIP blocks. Tests are skipped when you B expect them to B pass. Like an optional module is not installed or the operating system doesn't @@ -849,7 +850,7 @@ When the block is empty, delete it. ...normal testing code... } -With todo tests, it is best to have the tests actually run. That way +With todo tests, it's best to have the tests actually run. That way you'll know when they start passing. Sometimes this isn't possible. Often a failing test will cause the whole program to die or hang, even inside an C with and using C. In these extreme @@ -1181,7 +1182,7 @@ magic side-effects are kept to a minimum. WYSIWYG. =head1 SEE ALSO L if all this confuses you and you just want to write -some tests. You can upgrade to Test::More later (it is forward +some tests. You can upgrade to Test::More later (it's forward compatible). L for more ways to test complex data structures. diff --git a/lib/Test/Simple.pm b/lib/Test/Simple.pm index 1f50036..ee59bd3 100644 --- a/lib/Test/Simple.pm +++ b/lib/Test/Simple.pm @@ -4,7 +4,7 @@ use 5.004; use strict 'vars'; use vars qw($VERSION); -$VERSION = '0.42'; +$VERSION = '0.44'; use Test::Builder; @@ -61,8 +61,8 @@ You must have a plan. ok( $foo eq $bar, $name ); ok( $foo eq $bar ); -ok() is given an expression (in this case C<$foo eq $bar>). If it is -true, the test passed. If it is false, it didn't. That's about it. +ok() is given an expression (in this case C<$foo eq $bar>). If it's +true, the test passed. If it's false, it didn't. That's about it. ok() prints out either "ok" or "not ok" along with a test number (it keeps track of that for you). @@ -73,7 +73,7 @@ keeps track of that for you). If you provide a $name, that will be printed along with the "ok/not ok" to make it easier to find your test when if fails (just search for the name). It also makes it easier for the next guy to understand -what your test is for. It is highly recommended you use test names. +what your test is for. It's highly recommended you use test names. All tests are run in scalar context. So this: @@ -112,7 +112,7 @@ So the exit codes are... If you fail more than 254 tests, it will be reported as 254. This module is by no means trying to be a complete testing system. -It's just to get you started. Once you're off the ground it is +It's just to get you started. Once you're off the ground its recommended you look at L. diff --git a/lib/Test/Simple/Changes b/lib/Test/Simple/Changes index 2de6efc..38cbb48 100644 --- a/lib/Test/Simple/Changes +++ b/lib/Test/Simple/Changes @@ -1,5 +1,22 @@ Revision history for Perl extension Test::Simple +0.44 Thu Apr 25 00:27:27 EDT 2002 + - names containing newlines no longer produce confusing output + (from chromatic) + - chromatic provided a fix so can_ok() honors can() overrides. + - Nick Ing-Simmons suggested todo_skip() be a bit clearer about + the skipping part. + - Making plan() vomit if it gets something it doesn't understand. + - Tatsuhiko Miyagawa fixed use_ok() with pragmata on older perls. + - quieting diag(undef) + +0.43 Thu Apr 11 22:55:23 EDT 2002 + - Adrian Howard added TB->maybe_regex() + - Adding Mark Fowler's suggestion to make diag() return + false. + - TB->current_test() still not working when no tests were run via + TB itself. Fixed by Dave Rolsky. + 0.42 Wed Mar 6 15:00:24 EST 2002 - Setting Test::Builder->current_test() now works (see what happens when you forget to test things?) diff --git a/lib/Test/Simple/t/Builder.t b/lib/Test/Simple/t/Builder.t index a5bfd15..e10252e 100644 --- a/lib/Test/Simple/t/Builder.t +++ b/lib/Test/Simple/t/Builder.t @@ -10,7 +10,7 @@ BEGIN { use Test::Builder; my $Test = Test::Builder->new; -$Test->plan( tests => 7 ); +$Test->plan( tests => 9 ); my $default_lvl = $Test->level; $Test->level(0); @@ -28,3 +28,9 @@ $Test->current_test( $test_num ); print "ok $test_num - current_test() set\n"; $Test->ok( 1, 'counter still good' ); + +eval { $Test->plan(7); }; +$Test->like( $@, q{/^plan\(\) doesn't understand 7/}, 'bad plan()' ); + +eval { $Test->plan(wibble => 7); }; +$Test->like( $@, q{/^plan\(\) doesn't understand wibble 7/}, 'bad plan()' ); diff --git a/lib/Test/Simple/t/More.t b/lib/Test/Simple/t/More.t index bee2fb4..df8c5fe 100644 --- a/lib/Test/Simple/t/More.t +++ b/lib/Test/Simple/t/More.t @@ -7,7 +7,7 @@ BEGIN { } } -use Test::More tests => 37; +use Test::More tests => 41; # Make sure we don't mess with $@ or $!. Test at bottom. my $Err = "this should not be touched"; @@ -38,11 +38,28 @@ can_ok('Test::More', qw(require_ok use_ok ok is isnt like skip can_ok can_ok(bless({}, "Test::More"), qw(require_ok use_ok ok is isnt like skip can_ok pass fail eq_array eq_hash eq_set)); + isa_ok(bless([], "Foo"), "Foo"); isa_ok([], 'ARRAY'); isa_ok(\42, 'SCALAR'); +# can_ok() & isa_ok should call can() & isa() on the given object, not +# just class, in case of custom can() +{ + local *Foo::can; + local *Foo::isa; + *Foo::can = sub { $_[0]->[0] }; + *Foo::isa = sub { $_[0]->[0] }; + my $foo = bless([0], 'Foo'); + ok( ! $foo->can('bar') ); + ok( ! $foo->isa('bar') ); + $foo->[0] = 1; + can_ok( $foo, 'blah'); + isa_ok( $foo, 'blah'); +} + + pass('pass() passed'); ok( eq_array([qw(this that whatever)], [qw(this that whatever)]), diff --git a/lib/Test/Simple/t/curr_test.t b/lib/Test/Simple/t/curr_test.t new file mode 100644 index 0000000..edd201c --- /dev/null +++ b/lib/Test/Simple/t/curr_test.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl -w + +# Dave Rolsky found a bug where if current_test() is used and no +# tests are run via Test::Builder it will blow up. + +use Test::Builder; +$TB = Test::Builder->new; +$TB->plan(tests => 2); +print "ok 1\n"; +print "ok 2\n"; +$TB->current_test(2); diff --git a/lib/Test/Simple/t/diag.t b/lib/Test/Simple/t/diag.t index 0d6769b..453984b 100644 --- a/lib/Test/Simple/t/diag.t +++ b/lib/Test/Simple/t/diag.t @@ -9,7 +9,7 @@ BEGIN { use strict; -use Test::More tests => 5; +use Test::More tests => 7; my $Test = Test::More->builder; @@ -17,8 +17,10 @@ my $Test = Test::More->builder; my $output; tie *FAKEOUT, 'FakeOut', \$output; -# force diagnostic output to a filehandle, glad I added this to Test::Builder :) +# force diagnostic output to a filehandle, glad I added this to +# Test::Builder :) my @lines; +my $ret; { local $TODO = 1; $Test->todo_output(\*FAKEOUT); @@ -28,7 +30,7 @@ my @lines; push @lines, $output; $output = ''; - diag("multiple\n", "lines"); + $ret = diag("multiple\n", "lines"); push @lines, split(/\n/, $output); } @@ -36,14 +38,16 @@ is( @lines, 3, 'diag() should send messages to its filehandle' ); like( $lines[0], '/^#\s+/', ' should add comment mark to all lines' ); is( $lines[0], "# a single line\n", ' should send exact message' ); is( $output, "# multiple\n# lines\n", ' should append multi messages'); +ok( !$ret, 'diag returns false' ); { - local $TODO = 1; + $Test->failure_output(\*FAKEOUT); $output = ''; - diag("# foo"); + $ret = diag("# foo"); } +$Test->failure_output(\*STDERR); is( $output, "# # foo\n", "diag() adds a # even if there's one already" ); - +ok( !$ret, 'diag returns false' ); package FakeOut; diff --git a/lib/Test/Simple/t/exit.t b/lib/Test/Simple/t/exit.t index dcc4565..25e6259 100644 --- a/lib/Test/Simple/t/exit.t +++ b/lib/Test/Simple/t/exit.t @@ -54,6 +54,14 @@ my %Tests = ( print "1..".keys(%Tests)."\n"; +eval { require POSIX; &POSIX::WEXITSTATUS(0) }; +if( $@ ) { + *exitstatus = sub { $_[0] >> 8 }; +} +else { + *exitstatus = sub { POSIX::WEXITSTATUS($_[0]) } +} + chdir 't'; my $lib = File::Spec->catdir(qw(lib Test Simple sample_tests)); while( my($test_name, $exit_codes) = each %Tests ) { @@ -72,7 +80,7 @@ while( my($test_name, $exit_codes) = each %Tests ) { my $file = File::Spec->catfile($lib, $test_name); my $wait_stat = system(qq{$Perl -"I../blib/lib" -"I../lib" -"I../t/lib" $file}); - my $actual_exit = $wait_stat >> 8; + my $actual_exit = exitstatus($wait_stat); My::Test::ok( $actual_exit == $exit_code, "$test_name exited with $actual_exit (expected $exit_code)"); diff --git a/lib/Test/Simple/t/maybe_regex.t b/lib/Test/Simple/t/maybe_regex.t new file mode 100644 index 0000000..dcc84f4 --- /dev/null +++ b/lib/Test/Simple/t/maybe_regex.t @@ -0,0 +1,50 @@ +#!/usr/bin/perl -w + +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; +use Test::More tests => 10; + +use Test::Builder; +my $Test = Test::Builder->new; + +SKIP: { + skip "qr// added in 5.005", 3 if $] < 5.005; + + # 5.004 can't even see qr// or it pukes in compile. + eval q{ + my $r = $Test->maybe_regex(qr/^FOO$/i); + ok(defined $r, 'qr// detected'); + ok(('foo' =~ /$r/), 'qr// good match'); + ok(('bar' !~ /$r/), 'qr// bad match'); + }; + die $@ if $@; +} + +{ + my $r = $Test->maybe_regex('/^BAR$/i'); + ok(defined $r, '"//" detected'); + ok(('bar' =~ m/$r/), '"//" good match'); + ok(('foo' !~ m/$r/), '"//" bad match'); +}; + +{ + my $r = $Test->maybe_regex('not a regex'); + ok(!defined $r, 'non-regex detected'); +}; + + +{ + my $r = $Test->maybe_regex('/0/'); + ok(defined $r, 'non-regex detected'); + ok(('f00' =~ m/$r/), '"//" good match'); + ok(('b4r' !~ m/$r/), '"//" bad match'); +}; diff --git a/lib/Test/Simple/t/output.t b/lib/Test/Simple/t/output.t index 82dea28..dd051c1 100644 --- a/lib/Test/Simple/t/output.t +++ b/lib/Test/Simple/t/output.t @@ -3,12 +3,15 @@ BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; - @INC = '../lib'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; } } # Can't use Test.pm, that's a 5.005 thing. -print "1..3\n"; +print "1..4\n"; my $test_num = 1; # Utility testing functions. @@ -21,8 +24,11 @@ sub ok ($;$) { $ok .= "\n"; print $ok; $test_num++; + + return $test; } +use TieOut; use Test::Builder; my $Test = Test::Builder->new(); @@ -55,3 +61,32 @@ close IN; ok($lines[1] =~ /Hello!/); unlink('foo'); + + +# Ensure stray newline in name escaping works. +$out = tie *FAKEOUT, 'TieOut'; +$Test->output(\*FAKEOUT); +$Test->exported_to(__PACKAGE__); +$Test->no_ending(1); +$Test->plan(tests => 5); + +$Test->ok(1, "ok"); +$Test->ok(1, "ok\n"); +$Test->ok(1, "ok, like\nok"); +$Test->skip("wibble\nmoof"); +$Test->todo_skip("todo\nskip\n"); + +my $output = $out->read; +ok( $output eq <new; +my $orig_out = $Test->output; +my $orig_err = $Test->failure_output; +my $orig_todo = $Test->todo_output; + +$Test->output(\*FAKEOUT); +$Test->failure_output(\*FAKEOUT); +$Test->todo_output(\*FAKEOUT); +$Test->no_plan(); + +$Test->ok(1, "name\n"); +$Test->ok(0, "foo\nbar\nbaz"); +$Test->skip("\nmoofer"); +$Test->todo_skip("foo\n\n"); + diff --git a/lib/Test/Simple/t/undef.t b/lib/Test/Simple/t/undef.t index 5251264..00ce8b1 100644 --- a/lib/Test/Simple/t/undef.t +++ b/lib/Test/Simple/t/undef.t @@ -1,12 +1,18 @@ +#!/usr/bin/perl -w + BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; - @INC = '../lib'; + @INC = ('../lib', 'lib'); + } + else { + unshift @INC, 't/lib'; } } use strict; -use Test::More tests => 12; +use Test::More tests => 14; +use TieOut; BEGIN { $^W = 1; } @@ -41,3 +47,14 @@ eq_hash ( { foo => undef, bar => { baz => undef, moo => 23 } }, is( $warnings, '', 'eq_hash() no warnings' ); +my $tb = Test::More->builder; + +use TieOut; +my $caught = tie *CATCH, 'TieOut'; +my $old_fail = $tb->failure_output; +$tb->failure_output(\*CATCH); +diag(undef); +$tb->failure_output($old_fail); + +is( $caught->read, "# undef\n" ); +is( $warnings, '', 'diag(undef) no warnings' ); diff --git a/lib/Test/Simple/t/use_ok.t b/lib/Test/Simple/t/use_ok.t index f1d7bed..e944628 100644 --- a/lib/Test/Simple/t/use_ok.t +++ b/lib/Test/Simple/t/use_ok.t @@ -1,3 +1,5 @@ +#!/usr/bin/perl -w + BEGIN { if( $ENV{PERL_CORE} ) { chdir 't'; @@ -5,7 +7,7 @@ BEGIN { } } -use Test::More tests => 7; +use Test::More tests => 10; # Using Symbol because it's core and exports lots of stuff. { @@ -26,3 +28,11 @@ use Test::More tests => 7; ::use_ok("Symbol", qw(gensym ungensym)); ::ok( defined &gensym && defined &ungensym, ' multiple args' ); } + +{ + package Foo::four; + my $warn; local $SIG{__WARN__} = sub { $warn .= shift; }; + ::use_ok("constant", qw(foo bar)); + ::ok( defined &foo, 'constant' ); + ::is( $warn, undef, 'no warning'); +}