From: Michael G. Schwern Date: Tue, 29 May 2001 09:19:52 +0000 (+0100) Subject: Syncing with Test-1.17 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=809908f73d9628084b79065572fded532bb1d9f8;p=p5sagit%2Fp5-mst-13.2.git Syncing with Test-1.17 Message-ID: <20010529091952.R675@blackrider.blackstar.co.uk> p4raw-id: //depot/perl@10293 --- diff --git a/MANIFEST b/MANIFEST index 8c5d582..8da41ab 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1453,6 +1453,13 @@ t/io/tell.t See if file seeking works t/io/utf8.t See if file seeking works t/lib/1_compile.t See if the various libraries and extensions compile t/lib/MyFilter.pm Helper file for t/lib/filter-simple.t +t/lib/Test/fail.t See if Test works +t/lib/Test/mix.t See if Test works +t/lib/Test/onfail.t See if Test works +t/lib/Test/qr.t See if Test works +t/lib/Test/skip.t See if Test works +t/lib/Test/success.t See if Test works +t/lib/Test/todo.t See if Test works t/lib/abbrev.t See if Text::Abbrev works t/lib/ansicolor.t See if Term::ANSIColor works t/lib/anydbm.t See if AnyDBM_File works diff --git a/lib/Test.pm b/lib/Test.pm index 19a9089..eef2d38 100644 --- a/lib/Test.pm +++ b/lib/Test.pm @@ -1,18 +1,23 @@ -use strict; package Test; -use Test::Harness 1.1601 (); + +require 5.004; + +use strict; + use Carp; -our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $ntest, $TestLevel); #public-ish -our($TESTOUT, $ONFAIL, %todo, %history, $planned, @FAILDETAIL); #private-ish -$VERSION = '1.15'; +use vars (qw($VERSION @ISA @EXPORT @EXPORT_OK $ntest $TestLevel), #public-ish + qw($TESTOUT $ONFAIL %todo %history $planned @FAILDETAIL)#private-ish + ); + +$VERSION = '1.17'; require Exporter; @ISA=('Exporter'); -@EXPORT=qw(&plan &ok &skip); -@EXPORT_OK=qw($ntest $TESTOUT); + +@EXPORT = qw(&plan &ok &skip); +@EXPORT_OK = qw($ntest $TESTOUT); $TestLevel = 0; # how many extra stack frames to skip $|=1; -#$^W=1; ? $ntest=1; $TESTOUT = *STDOUT{IO}; @@ -20,9 +25,90 @@ $TESTOUT = *STDOUT{IO}; # help test coverage analyzers know which test is running. $ENV{REGRESSION_TEST} = $0; + +=head1 NAME + +Test - provides a simple framework for writing test scripts + +=head1 SYNOPSIS + + use strict; + use Test; + + # use a BEGIN block so we print our plan before MyModule is loaded + BEGIN { plan tests => 14, todo => [3,4] } + + # load your module... + use MyModule; + + ok(0); # failure + ok(1); # success + + ok(0); # ok, expected failure (see todo list, above) + ok(1); # surprise success! + + ok(0,1); # failure: '0' ne '1' + ok('broke','fixed'); # failure: 'broke' ne 'fixed' + ok('fixed','fixed'); # success: 'fixed' eq 'fixed' + ok('fixed',qr/x/); # success: 'fixed' =~ qr/x/ + + ok(sub { 1+1 }, 2); # success: '2' eq '2' + ok(sub { 1+1 }, 3); # failure: '2' ne '3' + ok(0, int(rand(2)); # (just kidding :-) + + my @list = (0,0); + ok @list, 3, "\@list=".join(',',@list); #extra diagnostics + ok 'segmentation fault', '/(?i)success/'; #regex match + + skip($feature_is_missing, ...); #do platform specific test + +=head1 DESCRIPTION + +L expects to see particular output when it +executes tests. This module aims to make writing proper test scripts just +a little bit easier (and less error prone :-). + + +=head2 Functions + +All the following are exported by Test by default. + +=over 4 + +=item B + + BEGIN { plan %theplan; } + +This should be the first thing you call in your test script. It +declares your testing plan, how many there will be, if any of them +should be allowed to fail, etc... + +Typical usage is just: + + use Test; + BEGIN { plan tests => 23 } + +Things you can put in the plan: + + tests The number of tests in your script. + This means all ok() and skip() calls. + todo A reference to a list of tests which are allowed + to fail. See L. + onfail A subroutine reference to be run at the end of + the test script should any of the tests fail. + See L. + +You must call plan() once and only once. + +=cut + sub plan { croak "Test::plan(%args): odd number of arguments" if @_ & 1; croak "Test::plan(): should not be called more than once" if $planned; + + local($\, $,); # guard against -l and other things that screw with + # print + my $max=0; for (my $x=0; $x < @_; $x+=2) { my ($k,$v) = @_[$x,$x+1]; @@ -42,35 +128,119 @@ sub plan { print $TESTOUT "1..$max\n"; } ++$planned; + + # Never used. + return undef; } -sub to_value { + +=begin _private + +=item B<_to_value> + + my $value = _to_value($input); + +Converts an ok parameter to its value. Typically this just means +running it if its a code reference. You should run all inputed +values through this. + +=cut + +sub _to_value { my ($v) = @_; - (ref $v or '') eq 'CODE' ? $v->() : $v; + return (ref $v or '') eq 'CODE' ? $v->() : $v; } +=end _private + +=item B + + ok(1 + 1 == 2); + ok($have, $expect); + ok($have, $expect, $diagnostics); + +This is the reason for Test's existance. Its the basic function that +handles printing "ok" or "not ok" along with the current test number. + +In its most basic usage, it simply takes an expression. If its true, +the test passes, if false, the test fails. Simp. + + ok( 1 + 1 == 2 ); # ok if 1 + 1 == 2 + ok( $foo =~ /bar/ ); # ok if $foo contains 'bar' + ok( baz($x + $y) eq 'Armondo' ); # ok if baz($x + $y) returns + # 'Armondo' + ok( @a == @b ); # ok if @a and @b are the same length + +The expression is evaluated in scalar context. So the following will +work: + + ok( @stuff ); # ok if @stuff has any elements + ok( !grep !defined $_, @stuff ); # ok if everything in @stuff is + # defined. + +A special case is if the expression is a subroutine reference. In +that case, it is executed and its value (true or false) determines if +the test passes or fails. + +In its two argument form it compares the two values to see if they +equal (with C). + + ok( "this", "that" ); # not ok, 'this' ne 'that' + +If either is a subroutine reference, that is run and used as a +comparison. + +Should $expect either be a regex reference (ie. qr//) or a string that +looks like a regex (ie. '/foo/') ok() will perform a pattern match +against it rather than using eq. + + ok( 'JaffO', '/Jaff/' ); # ok, 'JaffO' =~ /Jaff/ + ok( 'JaffO', qr/Jaff/ ); # ok, 'JaffO' =~ qr/Jaff/; + ok( 'JaffO', '/(?i)jaff/ ); # ok, 'JaffO' =~ /jaff/i; + +Finally, an optional set of $diagnostics will be printed should the +test fail. This should usually be some useful information about the +test pertaining to why it failed or perhaps a description of the test. +Or both. + + ok( grep($_ eq 'something unique', @stuff), 1, + "Something that should be unique isn't!\n". + '@stuff = '.join ', ', @stuff + ); + +Unfortunately, a diagnostic cannot be used with the single argument +style of ok(). + +All these special cases can cause some problems. See L. + +=cut + sub ok ($;$$) { croak "ok: plan before you test!" if !$planned; + + local($\,$,); # guard against -l and other things that screw with + # print + my ($pkg,$file,$line) = caller($TestLevel); my $repetition = ++$history{"$file:$line"}; my $context = ("$file at line $line". ($repetition > 1 ? " fail \#$repetition" : '')); my $ok=0; - my $result = to_value(shift); - my ($expected,$diag); + my $result = _to_value(shift); + my ($expected,$diag,$isregex,$regex); if (@_ == 0) { $ok = $result; } else { - $expected = to_value(shift); - my ($regex,$ignore); + $expected = _to_value(shift); if (!defined $expected) { $ok = !defined $result; } elsif (!defined $result) { $ok = 0; } elsif ((ref($expected)||'') eq 'Regexp') { $ok = $result =~ /$expected/; + $regex = $expected; } elsif (($regex) = ($expected =~ m,^ / (.+) / $,sx) or - ($ignore, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) { + (undef, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) { $ok = $result =~ /$regex/; } else { $ok = $result eq $expected; @@ -81,24 +251,24 @@ sub ok ($;$$) { $context .= ' TODO?!' if $todo; print $TESTOUT "ok $ntest # ($context)\n"; } else { - # Issuing two separate print()s causes severe trouble with - # Test::Harness on VMS. The "not "'s for failed tests occur - # on a separate line and would not get counted as failures. - #print $TESTOUT "not " if !$ok; - #print $TESTOUT "ok $ntest\n"; - # Replace with one of a pair of single print()'s as a workaround: - if (!$ok) { - print $TESTOUT "not ok $ntest\n"; + # Issuing two seperate prints() causes problems on VMS. + if (!$ok) { + print $TESTOUT "not ok $ntest\n"; } - else { - print $TESTOUT "ok $ntest\n"; + else { + print $TESTOUT "ok $ntest\n"; } if (!$ok) { my $detail = { 'repetition' => $repetition, 'package' => $pkg, 'result' => $result, 'todo' => $todo }; $$detail{expected} = $expected if defined $expected; - $diag = $$detail{diagnostic} = to_value(shift) if @_; + + # Get the user's diagnostic, protecting against multi-line + # diagnostics. + $diag = $$detail{diagnostic} = _to_value(shift) if @_; + $diag =~ s/\n/\n#/g if defined $diag; + $context .= ' *TODO*' if $todo; if (!defined $expected) { if (!$diag) { @@ -111,9 +281,10 @@ sub ok ($;$$) { print $TESTOUT "# $prefix got: ". (defined $result? "'$result'":'')." ($context)\n"; $prefix = ' ' x (length($prefix) - 5); - if ((ref($expected)||'') eq 'Regexp') { - $expected = 'qr/'.$expected.'/' - } else { + if (defined $regex) { + $expected = 'qr{'.$regex.'}'; + } + else { $expected = "'$expected'"; } if (!$diag) { @@ -129,19 +300,40 @@ sub ok ($;$$) { $ok; } -sub skip ($$;$$) { - my $whyskip = to_value(shift); - if ($whyskip) { - $whyskip = 'skip' if $whyskip =~ m/^\d+$/; - print $TESTOUT "ok $ntest # $whyskip\n"; - ++ $ntest; - 1; +sub skip ($;$$$) { + local($\, $,); # guard against -l and other things that screw with + # print + + my $whyskip = _to_value(shift); + if (!@_ or $whyskip) { + $whyskip = '' if $whyskip =~ m/^\d+$/; + $whyskip =~ s/^[Ss]kip(?:\s+|$)//; # backwards compatibility, old + # versions required the reason + # to start with 'skip' + # We print in one shot for VMSy reasons. + my $ok = "ok $ntest # skip"; + $ok .= " $whyskip" if length $whyskip; + $ok .= "\n"; + print $TESTOUT $ok; + ++ $ntest; + return 1; } else { + # backwards compatiblity (I think). skip() used to be + # called like ok() and was expected to fail, which is weird. + warn <(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL; } @@ -149,48 +341,6 @@ END { 1; __END__ -=head1 NAME - -Test - provides a simple framework for writing test scripts - -=head1 SYNOPSIS - - use strict; - use Test; - - # use a BEGIN block so we print our plan before MyModule is loaded - BEGIN { plan tests => 14, todo => [3,4] } - - # load your module... - use MyModule; - - ok(0); # failure - ok(1); # success - - ok(0); # ok, expected failure (see todo list, above) - ok(1); # surprise success! - - ok(0,1); # failure: '0' ne '1' - ok('broke','fixed'); # failure: 'broke' ne 'fixed' - ok('fixed','fixed'); # success: 'fixed' eq 'fixed' - ok('fixed',qr/x/); # success: 'fixed' =~ qr/x/ - - ok(sub { 1+1 }, 2); # success: '2' eq '2' - ok(sub { 1+1 }, 3); # failure: '2' ne '3' - ok(0, int(rand(2)); # (just kidding :-) - - my @list = (0,0); - ok @list, 3, "\@list=".join(',',@list); #extra diagnostics - ok 'segmentation fault', '/(?i)success/'; #regex match - - skip($feature_is_missing, ...); #do platform specific test - -=head1 DESCRIPTION - -L expects to see particular output when it -executes tests. This module aims to make writing proper test scripts just -a little bit easier (and less error prone :-). - =head1 TEST TYPES =over 4 @@ -221,11 +371,6 @@ notes or change log. =back -=head1 RETURN VALUE - -Both C and C return true if their test succeeds and false -otherwise in a scalar context. - =head1 ONFAIL BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } } @@ -248,13 +393,55 @@ running. (It is run inside an C block.) Besides, C is probably over-kill in most cases. (Your test code should be simpler than the code it is testing, yes?) + +=head1 BUGS and CAVEATS + +ok()'s special handling of subroutine references is an unfortunate +"feature" that can't be removed due to compatibility. + +ok()'s use of string eq can sometimes cause odd problems when comparing +numbers, especially if you're casting a string to a number: + + $foo = "1.0"; + ok( $foo, 1 ); # not ok, "1.0" ne 1 + +Your best bet is to use the single argument form: + + ok( $foo == 1 ); # ok "1.0" == 1 + +ok()'s special handing of strings which look like they might be +regexes can also cause unexpected behavior. An innocent: + + ok( $fileglob, '/path/to/some/*stuff/' ); + +will fail since Test.pm considers the second argument to a regex. +Again, best bet is to use the single argument form: + + ok( $fileglob eq '/path/to/some/*stuff/' ); + + +=head1 TODO + +Add todo(). + +Allow named tests. + +Implement noplan(). + + =head1 SEE ALSO -L and, perhaps, test coverage analysis tools. +L, L, L, L + +L is an interesting alternative testing library. + =head1 AUTHOR -Copyright (c) 1998-1999 Joshua Nathaniel Pritikin. All rights reserved. +Copyright (c) 1998-2000 Joshua Nathaniel Pritikin. All rights reserved. +Copyright (c) 2001 Michael G Schwern. + +Current maintainer, Michael G Schwern This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified diff --git a/t/TEST b/t/TEST index 3b4ce62..8f60c87 100755 --- a/t/TEST +++ b/t/TEST @@ -192,8 +192,9 @@ EOT print $_; } unless (/^#/) { - if (/^1\.\.([0-9]+)/) { + if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) { $max = $1; + %todo = map { $_ => 1 } split / /, $3 if $3; $totmax += $max; $files += 1; $next = 1; @@ -205,6 +206,7 @@ EOT { my($not, $num, $extra) = ($1, $2, $3); my($istodo) = $extra =~ /^\s*#\s*TODO/ if $extra; + $istodo = 1 if $todo{$num}; if( $not && !$istodo ) { $ok = 0; diff --git a/t/lib/Test/fail.t b/t/lib/Test/fail.t new file mode 100644 index 0000000..b431502 --- /dev/null +++ b/t/lib/Test/fail.t @@ -0,0 +1,93 @@ +# -*-perl-*- +use strict; +use vars qw($Expect); +use Test qw($TESTOUT $ntest ok skip plan); +plan tests => 14; + +open F, ">fails"; +$TESTOUT = *F{IO}; + +my $r=0; +{ + # Shut up deprecated usage warning. + local $^W = 0; + $r |= skip(0,0); +} +$r |= ok(0); +$r |= ok(0,1); +$r |= ok(sub { 1+1 }, 3); +$r |= ok(sub { 1+1 }, sub { 2 * 0}); + +my @list = (0,0); +$r |= ok @list, 1, "\@list=".join(',',@list); +$r |= ok @list, 1, sub { "\@list=".join ',',@list }; +$r |= ok 'segmentation fault', '/bongo/'; + +for (1..2) { $r |= ok(0); } + +$r |= ok(1, undef); +$r |= ok(undef, 1); + +ok($r); # (failure==success :-) + +close F; +$TESTOUT = *STDOUT{IO}; +$ntest = 1; + +open F, "fails"; +my $O; +while () { $O .= $_; } +close F; +unlink "fails"; + +ok join(' ', map { m/(\d+)/; $1 } grep /^not ok/, split /\n+/, $O), + join(' ', 1..13); + +my @got = split /not ok \d+\n/, $O; +shift @got; + +$Expect =~ s/\n+$//; +my @expect = split /\n\n/, $Expect; + +for (my $x=0; $x < @got; $x++) { + ok $got[$x], $expect[$x]."\n"; +} + + +BEGIN { + $Expect = <<"EXPECT"; +# Failed test 1 in $0 at line 14 + +# Failed test 2 in $0 at line 16 + +# Test 3 got: '0' ($0 at line 17) +# Expected: '1' + +# Test 4 got: '2' ($0 at line 18) +# Expected: '3' + +# Test 5 got: '2' ($0 at line 19) +# Expected: '0' + +# Test 6 got: '2' ($0 at line 22) +# Expected: '1' (\@list=0,0) + +# Test 7 got: '2' ($0 at line 23) +# Expected: '1' (\@list=0,0) + +# Test 8 got: 'segmentation fault' ($0 at line 24) +# Expected: qr{bongo} + +# Failed test 9 in $0 at line 26 + +# Failed test 10 in $0 at line 26 fail #2 + +# Failed test 11 in $0 at line 28 + +# Test 12 got: ($0 at line 29) +# Expected: '1' + +# Failed test 13 in $0 at line 31 +EXPECT + +} diff --git a/t/lib/Test/mix.t b/t/lib/Test/mix.t new file mode 100644 index 0000000..d911689 --- /dev/null +++ b/t/lib/Test/mix.t @@ -0,0 +1,17 @@ +# -*-perl-*- +use strict; +use Test; +BEGIN { plan tests => 4, todo => [2,3] } + +ok(sub { + my $r = 0; + for (my $x=0; $x < 10; $x++) { + $r += $x*($r+1); + } + $r + }, 3628799); + +ok(0); +ok(1); + +skip(1,0); diff --git a/t/lib/Test/onfail.t b/t/lib/Test/onfail.t new file mode 100644 index 0000000..dce4373 --- /dev/null +++ b/t/lib/Test/onfail.t @@ -0,0 +1,31 @@ +# -*-perl-*- + +use strict; +use Test qw($ntest plan ok $TESTOUT); +use vars qw($mycnt); + +BEGIN { plan test => 6, onfail => \&myfail } + +$mycnt = 0; + +my $why = "zero != one"; +# sneak in a test that Test::Harness wont see +open J, ">junk"; +$TESTOUT = *J{IO}; +ok(0, 1, $why); +$TESTOUT = *STDOUT{IO}; +close J; +unlink "junk"; +$ntest = 1; + +sub myfail { + my ($f) = @_; + ok(@$f, 1); + + my $t = $$f[0]; + ok($$t{diagnostic}, $why); + ok($$t{'package'}, 'main'); + ok($$t{repetition}, 1); + ok($$t{result}, 0); + ok($$t{expected}, 1); +} diff --git a/t/lib/Test/qr.t b/t/lib/Test/qr.t new file mode 100644 index 0000000..ea40f87 --- /dev/null +++ b/t/lib/Test/qr.t @@ -0,0 +1,13 @@ +#!./perl -w + +use strict; +BEGIN { + if ($] < 5.005) { + print "1..0\n"; + print "ok 1 # skipped; this test requires at least perl 5.005\n"; + exit; + } +} +use Test; plan tests => 1; + +ok 'abc', qr/b/; diff --git a/t/lib/Test/skip.t b/t/lib/Test/skip.t new file mode 100644 index 0000000..7db35e6 --- /dev/null +++ b/t/lib/Test/skip.t @@ -0,0 +1,40 @@ +# -*-perl-*- +use strict; +use Test qw($TESTOUT $ntest plan ok skip); plan tests => 6; + +open F, ">skips" or die "open skips: $!"; +$TESTOUT = *F{IO}; + +skip(1, 0); #should skip + +my $skipped=1; +skip('hop', sub { $skipped = 0 }); +skip(sub {'jump'}, sub { $skipped = 0 }); +skip('skipping stones is more fun', sub { $skipped = 0 }); + +close F; + +$TESTOUT = *STDOUT{IO}; +$ntest = 1; +open F, "skips" or die "open skips: $!"; + +ok $skipped, 1, 'not skipped?'; + +my @T = ; +chop @T; +my @expect = split /\n+/, join('',); +ok @T, 4; +for (my $x=0; $x < @T; $x++) { + ok $T[$x], $expect[$x]; +} + +END { close F; unlink "skips" } + +__DATA__ +ok 1 # skip + +ok 2 # skip hop + +ok 3 # skip jump + +ok 4 # skip skipping stones is more fun diff --git a/t/lib/Test/success.t b/t/lib/Test/success.t new file mode 100644 index 0000000..a580f0a --- /dev/null +++ b/t/lib/Test/success.t @@ -0,0 +1,11 @@ +# -*-perl-*- +use strict; +use Test; +BEGIN { plan tests => 11 } + +ok(ok(1)); +ok(ok('fixed', 'fixed')); +ok(skip(1,0)); +ok(undef, undef); +ok(ok 'the brown fox jumped over the lazy dog', '/lazy/'); +ok(ok 'the brown fox jumped over the lazy dog', 'm,fox,'); diff --git a/t/lib/Test/todo.t b/t/lib/Test/todo.t new file mode 100644 index 0000000..ae02a04 --- /dev/null +++ b/t/lib/Test/todo.t @@ -0,0 +1,13 @@ +# -*-perl-*- +use strict; +use Test; +BEGIN { + my $tests = 5; + plan tests => $tests, todo => [1..$tests]; +} + +ok(0); +ok(1); +ok(0,1); +ok(0,1,"need more tuits"); +ok(1,1);