X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FTest.pm;h=47ed888d791cbde919e3269aa25f4ff81d9ae270;hb=446eaa427e017001f2d47e21b0ad20ce965cd808;hp=19a9089978208d9332b29b0481c2d786edb1062f;hpb=bbc7dcd2bd43efd6773e46b614c6eb1db5af78d2;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/Test.pm b/lib/Test.pm index 19a9089..47ed888 100644 --- a/lib/Test.pm +++ b/lib/Test.pm @@ -1,28 +1,159 @@ -use strict; + +require 5.004; package Test; -use Test::Harness 1.1601 (); +# Time-stamp: "2002-08-26 03:09:51 MDT" + +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 $TESTERR %Program_Lines + $ONFAIL %todo %history $planned @FAILDETAIL) #private-ish + ); + +# In case a test is run in a persistent environment. +sub _reset_globals { + %todo = (); + %history = (); + @FAILDETAIL = (); + $ntest = 1; + $TestLevel = 0; # how many extra stack frames to skip + $planned = 0; +} + +$VERSION = '1.21'; require Exporter; @ISA=('Exporter'); -@EXPORT=qw(&plan &ok &skip); -@EXPORT_OK=qw($ntest $TESTOUT); -$TestLevel = 0; # how many extra stack frames to skip +@EXPORT = qw(&plan &ok &skip); +@EXPORT_OK = qw($ntest $TESTOUT $TESTERR); + $|=1; -#$^W=1; ? -$ntest=1; $TESTOUT = *STDOUT{IO}; +$TESTERR = *STDERR{IO}; # Use of this variable is strongly discouraged. It is set mainly to # 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; + + # Helpful notes. All note-lines must start with a "#". + print "# I'm testing MyModule version $MyModule::VERSION\n"; + + 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' + + my @list = (0,0); + ok @list, 3, "\@list=".join(',',@list); #extra notes + ok 'segmentation fault', '/(?i)success/'; #regex match + + skip( + $^O eq 'MSWin' ? "Not for MSWin" : 0, # whether to skip + $foo, $bar # arguments just like for ok(...) + ); + +=head1 DESCRIPTION + +This module simplifies the task of writing test files for Perl modules, +such that their output is in the format that +L expects to see. + +=head1 QUICK START GUIDE + +To write a test for your new (and probably not even done) module, create +a new file called F (in a new F directory). If you have +multiple test files, to test the "foo", "bar", and "baz" feature sets, +then feel free to call your files F, F, and +F + +=head2 Functions + +This module defines three public functions, C, C, +and C. By default, all three are exported by +the C statement. + +=over 4 + +=item C + + 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, and so on. + +Typical usage is just: + + use Test; + BEGIN { plan tests => 23 } + +These are the things that you can put in the parameters to plan: + +=over + +=item C I> + +The number of tests in your script. +This means all ok() and skip() calls. + +=item C [I<1,5,14>]> + +A reference to a list of tests which are allowed to fail. +See L. + +=item C sub { ... }> + +=item C \&some_sub> + +A subroutine reference to be run at the end of the test script, if +any of the tests fail. See L. + +=back + +You must call C once and only once. You should call it +in a C block, like so: + + BEGIN { plan tests => 23 } + +=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 + + _reset_globals(); + + _read_program( (caller)[1] ); + my $max=0; for (my $x=0; $x < @_; $x+=2) { my ($k,$v) = @_[$x,$x+1]; @@ -42,35 +173,188 @@ sub plan { print $TESTOUT "1..$max\n"; } ++$planned; + print $TESTOUT "# Running under perl version $] for $^O", + (chr(65) eq 'A') ? "\n" : " in a non-ASCII world\n"; + + print $TESTOUT "# Win32::BuildNumber ", &Win32::BuildNumber(), "\n" + if defined(&Win32::BuildNumber) and defined &Win32::BuildNumber(); + + print $TESTOUT "# MacPerl verison $MacPerl::Version\n" + if defined $MacPerl::Version; + + printf $TESTOUT + "# Current time local: %s\n# Current time GMT: %s\n", + scalar( gmtime($^T)), scalar(localtime($^T)); + + print $TESTOUT "# Using Test.pm version $VERSION\n"; + + # Retval never used: + return undef; +} + +sub _read_program { + my($file) = shift; + return unless defined $file and length $file + and -e $file and -f _ and -r _; + open(SOURCEFILE, "<$file") || return; + $Program_Lines{$file} = []; + close(SOURCEFILE); + + foreach my $x (@{$Program_Lines{$file}}) + { $x =~ tr/[\cm\cj\n\r]//d } + + unshift @{$Program_Lines{$file}}, ''; + return 1; } -sub to_value { +=begin _private + +=item B<_to_value> + + my $value = _to_value($input); + +Converts an C parameter to its value. Typically this just means +running it, if it's a code reference. You should run all inputted +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 C + + ok(1 + 1 == 2); + ok($have, $expect); + ok($have, $expect, $diagnostics); + +This function is the reason for C's existence. It's +the basic function that +handles printing "C" or "C", along with the +current test number. (That's what C wants to see.) + +In its most basic usage, C simply takes a single scalar +expression. If its value is true, the test passes; if false, +the test fails. Examples: + + # Examples of ok(scalar) + + 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 either +C syntax or C<\&foo> syntax). In +that case, it is executed and its value (true or false) determines if +the test passes or fails. For example, + + ok( sub { # See whether sleep works at least passably + my $start_time = time; + sleep 5; + time() - $start_time >= 4 + }); + +In its two-argument form, C,I)> compares the two scalar +values to see if they equal. (The equality is checked with C). + + # Example of ok(scalar, scalar) + + ok( "this", "that" ); # not ok, 'this' ne 'that' + +If either (or both!) is a subroutine reference, it is run and used +as the value for comparing. For example: + + ok 4, sub { + open(OUT, ">x.dat") || die $!; + print OUT "\x{e000}"; + close OUT; + my $bytecount = -s 'x.dat'; + unlink 'x.dat' or warn "Can't unlink : $!"; + return $bytecount; + }, + ; + +The above test passes two values to C -- the first is +the number 4, and the second is a coderef. Before C compares them, +it calls the coderef, and uses its return value as the real value of +this parameter. Assuming that C<$bytecount> returns 4, C ends up +testing C<4 eq 4>. Since that's true, this test passes. + +If C is either a regex object (i.e., C) or a string +that I a regex (e.g., C<'/foo/'>), then +C,I)> will perform a pattern +match against it, instead of using C. + + ok( 'JaffO', '/Jaff/' ); # ok, 'JaffO' =~ /Jaff/ + ok( 'JaffO', qr/Jaff/ ); # ok, 'JaffO' =~ qr/Jaff/; + ok( 'JaffO', '/(?i)jaff/ ); # ok, 'JaffO' =~ /jaff/i; + +Finally, you can append an optional third argument, in +C,I, I)>, where I is a string value that +will be printed if the test fails. This should be some useful +information about the test, pertaining to why it failed, and/or +a description of the test. For example: + + ok( grep($_ eq 'something unique', @stuff), 1, + "Something that should be unique isn't!\n". + '@stuff = '.join ', ', @stuff + ); + +Unfortunately, a note cannot be used with the single argument +style of C. That is, if you try C, I)>, then +C will interpret this as C, I)>, and probably +end up testing C eq I> -- and that's not what you want! + +All of the above special cases can occasionally cause some +problems. See L. + +=cut + +# A past maintainer of this module said: +# <> +# + 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,47 +365,61 @@ 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) { - print $TESTOUT "# Failed test $ntest in $context\n"; + print $TESTERR "# Failed test $ntest in $context\n"; } else { - print $TESTOUT "# Failed test $ntest in $context: $diag\n"; + print $TESTERR "# Failed test $ntest in $context: $diag\n"; } } else { my $prefix = "Test $ntest"; - print $TESTOUT "# $prefix got: ". + print $TESTERR "# $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) { - print $TESTOUT "# $prefix Expected: $expected\n"; + print $TESTERR "# $prefix Expected: $expected\n"; } else { - print $TESTOUT "# $prefix Expected: $expected ($diag)\n"; + print $TESTERR "# $prefix Expected: $expected ($diag)\n"; } } + + if(defined $Program_Lines{$file}[$line]) { + print $TESTERR + "# $file line $line is: $Program_Lines{$file}[$line]\n" + if + $Program_Lines{$file}[$line] =~ m/[^\s\#\(\)\{\}\[\]\;]/ + # Otherwise it's a pretty uninteresting line! + ; + + undef $Program_Lines{$file}[$line]; + # So we won't repeat it. + } + push @FAILDETAIL, $detail; } } @@ -129,67 +427,124 @@ 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; - } else { - local($TestLevel) = $TestLevel+1; #ignore this stack frame - &ok; - } -} +=item C, I)> -END { - $ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL; -} +This is used for tests that under some conditions can be skipped. It's +basically equivalent to: -1; -__END__ + if( $skip_if_true ) { + ok(1); + } else { + ok( args... ); + } -=head1 NAME +...except that the C emits not just "C>" but +actually "C # I>". -Test - provides a simple framework for writing test scripts +The arguments after the I are what is fed to C if +this test isn't skipped. -=head1 SYNOPSIS +Example usage: - use strict; - use Test; + my $if_MSWin = + $^O eq 'MSWin' ? 'Skip if under MSWin' : ''; - # use a BEGIN block so we print our plan before MyModule is loaded - BEGIN { plan tests => 14, todo => [3,4] } + # A test to be run EXCEPT under MSWin: + skip($if_MSWin, thing($foo), thing($bar) ); - # load your module... - use MyModule; +Or, going the other way: - ok(0); # failure - ok(1); # success + my $unless_MSWin = + $^O eq 'MSWin' ? 'Skip unless under MSWin' : ''; - ok(0); # ok, expected failure (see todo list, above) - ok(1); # surprise success! + # A test to be run EXCEPT under MSWin: + skip($unless_MSWin, thing($foo), thing($bar) ); - 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/ +The only tricky thing to remember is that the first parameter is true if +you want to I the test, not I it; and it also doubles as a +note about why it's being skipped. So in the first codeblock above, read +the code as "skip if MSWin -- (otherwise) test whether C is +C" or for the second case, "skip unless MSWin...". - 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 :-) +Also, when your I string is true, it really should (for +backwards compatibility with older Test.pm versions) start with the +string "Skip", as shown in the above examples. - my @list = (0,0); - ok @list, 3, "\@list=".join(',',@list); #extra diagnostics - ok 'segmentation fault', '/(?i)success/'; #regex match +Note that in the above cases, C and C +I evaluated -- but as long as the C is true, +then we C just tosses out their value (i.e., not +bothering to treat them like values to C. But if +you need to I eval the arguments when skipping the +test, use +this format: - skip($feature_is_missing, ...); #do platform specific test + skip( $unless_MSWin, + sub { + # This code returns true if the test passes. + # (But it doesn't even get called if the test is skipped.) + thing($foo) eq thing($bar) + } + ); -=head1 DESCRIPTION +or even this, which is basically equivalent: -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 :-). + skip( $unless_MSWin, + sub { thing($foo) }, sub { thing($bar) } + ); + +That is, both are like this: + + if( $unless_MSWin ) { + ok(1); # but it actually appends "# $unless_MSWin" + # so that Test::Harness can tell it's a skip + } else { + # Not skipping, so actually call and evaluate... + ok( sub { thing($foo) }, sub { thing($bar) } ); + } + +=cut + +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(), which is weird. I haven't decided what to do with + # this yet. +# warn <(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL; +} + +1; +__END__ =head1 TEST TYPES @@ -197,49 +552,47 @@ a little bit easier (and less error prone :-). =item * NORMAL TESTS -These tests are expected to succeed. If they don't something's -screwed up! +These tests are expected to succeed. Usually, most or all of your tests +are in this category. If a normal test doesn't succeed, then that +means that something is I. =item * SKIPPED TESTS -Skip is for tests that might or might not be possible to run depending -on the availability of platform specific features. The first argument +The C function is for tests that might or might not be +possible to run, depending +on the availability of platform-specific features. The first argument should evaluate to true (think "yes, please skip") if the required -feature is not available. After the first argument, skip works -exactly the same way as do normal tests. +feature is I available. After the first argument, C works +exactly the same way as C does. =item * TODO TESTS TODO tests are designed for maintaining an B. -These tests are expected NOT to succeed. If a TODO test does succeed, -the feature in question should not be on the TODO list, now should it? +These tests are I If a TODO test does succeed, +then the feature in question shouldn't be on the TODO list, now +should it? Packages should NOT be released with succeeding TODO tests. As soon -as a TODO test starts working, it should be promoted to a normal test +as a TODO test starts working, it should be promoted to a normal test, and the newly working feature should be documented in the release -notes or change log. +notes or in the 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!" } } -While test failures should be enough, extra diagnostics can be +Although test failures should be enough, extra diagnostics can be triggered at the end of a test run. C is passed an array ref of hash refs that describe each test failure. Each hash will contain at least the following fields: C, C, and C. (The file, line, and test number are not included because their correspondence to a particular test is tenuous.) If the test -had an expected value or a diagnostic string, these will also be +had an expected value or a diagnostic (or "note") string, these will also be included. -The B C hook might be used simply to print out the +The I C hook might be used simply to print out the version of your package and/or how to report problems. It might also be used to generate extremely sophisticated diagnostics for a particularly bizarre test failure. However it's not a panacea. Core @@ -248,17 +601,89 @@ 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 + +=over + +=item * + +C'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 be a regex! +The best bet is to use the one-argument form: + + ok( $fileglob eq '/path/to/some/*stuff/' ); + +=item * + +C's use of string C 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 + +=item * + +As you may have inferred from the above documentation and examples, +C's prototype is C<($;$$)> (and, incidentally, C's is +C<($;$$$)>). This means, for example, that you can do C +to compare the I of the two arrays. But don't be fooled into +thinking that C means a comparison of the contents of two +arrays -- you're comparing I the number of elements of each. It's +so easy to make that mistake in reading C that you might +want to be very explicit about it, and instead write C. + +=back + +=head1 NOTE + +A past developer of this module once said that it was no longer being +actively developed. However, rumors of its demise were greatly +exaggerated. Feedback and suggestions are quite welcome. + +Be aware that the main value of this module is its simplicity. Note +that there are already more ambitious modules out there, such as +L and L. + + =head1 SEE ALSO -L and, perhaps, test coverage analysis tools. +L + +L, L, L + +L for building your own testing library. + +L is an interesting XUnit-style testing library. + +L and L let you embed tests in code. + =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-2002 Michael G. Schwern. + +Copyright (c) 2002 Sean M. Burke. + +Current maintainer: Sean M. Burke. Esburke@cpan.orgE This package is free software and is provided "as is" without express or implied warranty. It may be used, redistributed and/or modified -under the terms of the Perl Artistic License (see -http://www.perl.com/perl/misc/Artistic.html) +under the same terms as Perl itself. =cut + +# "Your mistake was a hidden intention." +# -- /Oblique Strategies/, Brian Eno and Peter Schmidt