I don't think trying to bracket the hires time with lores
[p5sagit/p5-mst-13.2.git] / lib / Test.pm
CommitLineData
7b13a3f5 1package Test;
809908f7 2
3require 5.004;
4
5use strict;
6
7b13a3f5 7use Carp;
809908f7 8use vars (qw($VERSION @ISA @EXPORT @EXPORT_OK $ntest $TestLevel), #public-ish
9 qw($TESTOUT $ONFAIL %todo %history $planned @FAILDETAIL)#private-ish
10 );
11
edd5bad5 12$VERSION = '1.18';
7b13a3f5 13require Exporter;
14@ISA=('Exporter');
809908f7 15
16@EXPORT = qw(&plan &ok &skip);
17@EXPORT_OK = qw($ntest $TESTOUT);
7b13a3f5 18
3238f5fe 19$TestLevel = 0; # how many extra stack frames to skip
7b13a3f5 20$|=1;
7b13a3f5 21$ntest=1;
f2ac83ee 22$TESTOUT = *STDOUT{IO};
7b13a3f5 23
3238f5fe 24# Use of this variable is strongly discouraged. It is set mainly to
25# help test coverage analyzers know which test is running.
7b13a3f5 26$ENV{REGRESSION_TEST} = $0;
27
809908f7 28
29=head1 NAME
30
31Test - provides a simple framework for writing test scripts
32
33=head1 SYNOPSIS
34
35 use strict;
36 use Test;
37
38 # use a BEGIN block so we print our plan before MyModule is loaded
39 BEGIN { plan tests => 14, todo => [3,4] }
40
41 # load your module...
42 use MyModule;
43
44 ok(0); # failure
45 ok(1); # success
46
47 ok(0); # ok, expected failure (see todo list, above)
48 ok(1); # surprise success!
49
50 ok(0,1); # failure: '0' ne '1'
51 ok('broke','fixed'); # failure: 'broke' ne 'fixed'
52 ok('fixed','fixed'); # success: 'fixed' eq 'fixed'
53 ok('fixed',qr/x/); # success: 'fixed' =~ qr/x/
54
55 ok(sub { 1+1 }, 2); # success: '2' eq '2'
56 ok(sub { 1+1 }, 3); # failure: '2' ne '3'
57 ok(0, int(rand(2)); # (just kidding :-)
58
59 my @list = (0,0);
60 ok @list, 3, "\@list=".join(',',@list); #extra diagnostics
61 ok 'segmentation fault', '/(?i)success/'; #regex match
62
63 skip($feature_is_missing, ...); #do platform specific test
64
65=head1 DESCRIPTION
66
edd5bad5 67B<STOP!> If you are writing a new test, we I<highly suggest> you use
68the new Test::Simple and Test::More modules instead.
69
809908f7 70L<Test::Harness|Test::Harness> expects to see particular output when it
71executes tests. This module aims to make writing proper test scripts just
72a little bit easier (and less error prone :-).
73
74
75=head2 Functions
76
77All the following are exported by Test by default.
78
79=over 4
80
81=item B<plan>
82
83 BEGIN { plan %theplan; }
84
85This should be the first thing you call in your test script. It
86declares your testing plan, how many there will be, if any of them
87should be allowed to fail, etc...
88
89Typical usage is just:
90
91 use Test;
92 BEGIN { plan tests => 23 }
93
94Things you can put in the plan:
95
96 tests The number of tests in your script.
97 This means all ok() and skip() calls.
98 todo A reference to a list of tests which are allowed
99 to fail. See L</TODO TESTS>.
100 onfail A subroutine reference to be run at the end of
101 the test script should any of the tests fail.
102 See L</ONFAIL>.
103
104You must call plan() once and only once.
105
106=cut
107
7b13a3f5 108sub plan {
109 croak "Test::plan(%args): odd number of arguments" if @_ & 1;
8b3be1d1 110 croak "Test::plan(): should not be called more than once" if $planned;
809908f7 111
112 local($\, $,); # guard against -l and other things that screw with
113 # print
114
7b13a3f5 115 my $max=0;
116 for (my $x=0; $x < @_; $x+=2) {
117 my ($k,$v) = @_[$x,$x+1];
118 if ($k =~ /^test(s)?$/) { $max = $v; }
119 elsif ($k eq 'todo' or
120 $k eq 'failok') { for (@$v) { $todo{$_}=1; }; }
8b3be1d1 121 elsif ($k eq 'onfail') {
122 ref $v eq 'CODE' or croak "Test::plan(onfail => $v): must be CODE";
123 $ONFAIL = $v;
124 }
7b13a3f5 125 else { carp "Test::plan(): skipping unrecognized directive '$k'" }
126 }
127 my @todo = sort { $a <=> $b } keys %todo;
128 if (@todo) {
f2ac83ee 129 print $TESTOUT "1..$max todo ".join(' ', @todo).";\n";
7b13a3f5 130 } else {
f2ac83ee 131 print $TESTOUT "1..$max\n";
7b13a3f5 132 }
8b3be1d1 133 ++$planned;
809908f7 134
135 # Never used.
136 return undef;
7b13a3f5 137}
138
809908f7 139
140=begin _private
141
142=item B<_to_value>
143
144 my $value = _to_value($input);
145
146Converts an ok parameter to its value. Typically this just means
147running it if its a code reference. You should run all inputed
148values through this.
149
150=cut
151
152sub _to_value {
3238f5fe 153 my ($v) = @_;
809908f7 154 return (ref $v or '') eq 'CODE' ? $v->() : $v;
3238f5fe 155}
156
809908f7 157=end _private
158
159=item B<ok>
160
161 ok(1 + 1 == 2);
162 ok($have, $expect);
163 ok($have, $expect, $diagnostics);
164
165This is the reason for Test's existance. Its the basic function that
166handles printing "ok" or "not ok" along with the current test number.
167
168In its most basic usage, it simply takes an expression. If its true,
169the test passes, if false, the test fails. Simp.
170
171 ok( 1 + 1 == 2 ); # ok if 1 + 1 == 2
172 ok( $foo =~ /bar/ ); # ok if $foo contains 'bar'
173 ok( baz($x + $y) eq 'Armondo' ); # ok if baz($x + $y) returns
174 # 'Armondo'
175 ok( @a == @b ); # ok if @a and @b are the same length
176
177The expression is evaluated in scalar context. So the following will
178work:
179
180 ok( @stuff ); # ok if @stuff has any elements
181 ok( !grep !defined $_, @stuff ); # ok if everything in @stuff is
182 # defined.
183
184A special case is if the expression is a subroutine reference. In
185that case, it is executed and its value (true or false) determines if
186the test passes or fails.
187
188In its two argument form it compares the two values to see if they
189equal (with C<eq>).
190
191 ok( "this", "that" ); # not ok, 'this' ne 'that'
192
193If either is a subroutine reference, that is run and used as a
194comparison.
195
196Should $expect either be a regex reference (ie. qr//) or a string that
197looks like a regex (ie. '/foo/') ok() will perform a pattern match
198against it rather than using eq.
199
200 ok( 'JaffO', '/Jaff/' ); # ok, 'JaffO' =~ /Jaff/
201 ok( 'JaffO', qr/Jaff/ ); # ok, 'JaffO' =~ qr/Jaff/;
202 ok( 'JaffO', '/(?i)jaff/ ); # ok, 'JaffO' =~ /jaff/i;
203
204Finally, an optional set of $diagnostics will be printed should the
205test fail. This should usually be some useful information about the
206test pertaining to why it failed or perhaps a description of the test.
207Or both.
208
209 ok( grep($_ eq 'something unique', @stuff), 1,
210 "Something that should be unique isn't!\n".
211 '@stuff = '.join ', ', @stuff
212 );
213
214Unfortunately, a diagnostic cannot be used with the single argument
215style of ok().
216
217All these special cases can cause some problems. See L</BUGS and CAVEATS>.
218
219=cut
220
8b3be1d1 221sub ok ($;$$) {
222 croak "ok: plan before you test!" if !$planned;
809908f7 223
224 local($\,$,); # guard against -l and other things that screw with
225 # print
226
3238f5fe 227 my ($pkg,$file,$line) = caller($TestLevel);
228 my $repetition = ++$history{"$file:$line"};
229 my $context = ("$file at line $line".
8b3be1d1 230 ($repetition > 1 ? " fail \#$repetition" : ''));
3238f5fe 231 my $ok=0;
809908f7 232 my $result = _to_value(shift);
233 my ($expected,$diag,$isregex,$regex);
3238f5fe 234 if (@_ == 0) {
8b3be1d1 235 $ok = $result;
3238f5fe 236 } else {
809908f7 237 $expected = _to_value(shift);
59e80644 238 if (!defined $expected) {
239 $ok = !defined $result;
240 } elsif (!defined $result) {
241 $ok = 0;
242 } elsif ((ref($expected)||'') eq 'Regexp') {
f2ac83ee 243 $ok = $result =~ /$expected/;
809908f7 244 $regex = $expected;
f2ac83ee 245 } elsif (($regex) = ($expected =~ m,^ / (.+) / $,sx) or
809908f7 246 (undef, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) {
8b3be1d1 247 $ok = $result =~ /$regex/;
3238f5fe 248 } else {
3238f5fe 249 $ok = $result eq $expected;
250 }
8b3be1d1 251 }
f2ac83ee 252 my $todo = $todo{$ntest};
253 if ($todo and $ok) {
254 $context .= ' TODO?!' if $todo;
255 print $TESTOUT "ok $ntest # ($context)\n";
8b3be1d1 256 } else {
809908f7 257 # Issuing two seperate prints() causes problems on VMS.
258 if (!$ok) {
259 print $TESTOUT "not ok $ntest\n";
e5420382 260 }
809908f7 261 else {
262 print $TESTOUT "ok $ntest\n";
e5420382 263 }
8b3be1d1 264
265 if (!$ok) {
266 my $detail = { 'repetition' => $repetition, 'package' => $pkg,
f2ac83ee 267 'result' => $result, 'todo' => $todo };
8b3be1d1 268 $$detail{expected} = $expected if defined $expected;
809908f7 269
270 # Get the user's diagnostic, protecting against multi-line
271 # diagnostics.
272 $diag = $$detail{diagnostic} = _to_value(shift) if @_;
273 $diag =~ s/\n/\n#/g if defined $diag;
274
f2ac83ee 275 $context .= ' *TODO*' if $todo;
8b3be1d1 276 if (!defined $expected) {
3238f5fe 277 if (!$diag) {
f2ac83ee 278 print $TESTOUT "# Failed test $ntest in $context\n";
3238f5fe 279 } else {
f2ac83ee 280 print $TESTOUT "# Failed test $ntest in $context: $diag\n";
3238f5fe 281 }
8b3be1d1 282 } else {
283 my $prefix = "Test $ntest";
59e80644 284 print $TESTOUT "# $prefix got: ".
285 (defined $result? "'$result'":'<UNDEF>')." ($context)\n";
8b3be1d1 286 $prefix = ' ' x (length($prefix) - 5);
809908f7 287 if (defined $regex) {
288 $expected = 'qr{'.$regex.'}';
289 }
290 else {
f2ac83ee 291 $expected = "'$expected'";
292 }
8b3be1d1 293 if (!$diag) {
f2ac83ee 294 print $TESTOUT "# $prefix Expected: $expected\n";
3238f5fe 295 } else {
f2ac83ee 296 print $TESTOUT "# $prefix Expected: $expected ($diag)\n";
3238f5fe 297 }
298 }
8b3be1d1 299 push @FAILDETAIL, $detail;
7b13a3f5 300 }
7b13a3f5 301 }
302 ++ $ntest;
303 $ok;
304}
305
809908f7 306sub skip ($;$$$) {
307 local($\, $,); # guard against -l and other things that screw with
308 # print
309
310 my $whyskip = _to_value(shift);
311 if (!@_ or $whyskip) {
312 $whyskip = '' if $whyskip =~ m/^\d+$/;
313 $whyskip =~ s/^[Ss]kip(?:\s+|$)//; # backwards compatibility, old
314 # versions required the reason
315 # to start with 'skip'
316 # We print in one shot for VMSy reasons.
317 my $ok = "ok $ntest # skip";
318 $ok .= " $whyskip" if length $whyskip;
319 $ok .= "\n";
320 print $TESTOUT $ok;
321 ++ $ntest;
322 return 1;
7b13a3f5 323 } else {
809908f7 324 # backwards compatiblity (I think). skip() used to be
316cf57b 325 # called like ok(), which is weird. I haven't decided what to do with
326 # this yet.
327# warn <<WARN if $^W;
328#This looks like a skip() using the very old interface. Please upgrade to
329#the documented interface as this has been deprecated.
330#WARN
809908f7 331
8b3be1d1 332 local($TestLevel) = $TestLevel+1; #ignore this stack frame
809908f7 333 return &ok(@_);
7b13a3f5 334 }
335}
336
809908f7 337=back
338
339=cut
340
8b3be1d1 341END {
342 $ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL;
343}
344
7b13a3f5 3451;
346__END__
347
3238f5fe 348=head1 TEST TYPES
7b13a3f5 349
350=over 4
351
352=item * NORMAL TESTS
353
f2ac83ee 354These tests are expected to succeed. If they don't something's
3238f5fe 355screwed up!
7b13a3f5 356
357=item * SKIPPED TESTS
358
f2ac83ee 359Skip is for tests that might or might not be possible to run depending
360on the availability of platform specific features. The first argument
361should evaluate to true (think "yes, please skip") if the required
362feature is not available. After the first argument, skip works
3238f5fe 363exactly the same way as do normal tests.
7b13a3f5 364
365=item * TODO TESTS
366
f2ac83ee 367TODO tests are designed for maintaining an B<executable TODO list>.
368These tests are expected NOT to succeed. If a TODO test does succeed,
369the feature in question should not be on the TODO list, now should it?
7b13a3f5 370
f2ac83ee 371Packages should NOT be released with succeeding TODO tests. As soon
7b13a3f5 372as a TODO test starts working, it should be promoted to a normal test
f2ac83ee 373and the newly working feature should be documented in the release
374notes or change log.
7b13a3f5 375
376=back
377
8b3be1d1 378=head1 ONFAIL
379
380 BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } }
381
f2ac83ee 382While test failures should be enough, extra diagnostics can be
383triggered at the end of a test run. C<onfail> is passed an array ref
384of hash refs that describe each test failure. Each hash will contain
385at least the following fields: C<package>, C<repetition>, and
386C<result>. (The file, line, and test number are not included because
f610777f 387their correspondence to a particular test is tenuous.) If the test
f2ac83ee 388had an expected value or a diagnostic string, these will also be
389included.
390
391The B<optional> C<onfail> hook might be used simply to print out the
392version of your package and/or how to report problems. It might also
393be used to generate extremely sophisticated diagnostics for a
394particularly bizarre test failure. However it's not a panacea. Core
395dumps or other unrecoverable errors prevent the C<onfail> hook from
396running. (It is run inside an C<END> block.) Besides, C<onfail> is
397probably over-kill in most cases. (Your test code should be simpler
8b3be1d1 398than the code it is testing, yes?)
399
809908f7 400
401=head1 BUGS and CAVEATS
402
403ok()'s special handling of subroutine references is an unfortunate
404"feature" that can't be removed due to compatibility.
405
406ok()'s use of string eq can sometimes cause odd problems when comparing
407numbers, especially if you're casting a string to a number:
408
409 $foo = "1.0";
410 ok( $foo, 1 ); # not ok, "1.0" ne 1
411
412Your best bet is to use the single argument form:
413
414 ok( $foo == 1 ); # ok "1.0" == 1
415
416ok()'s special handing of strings which look like they might be
417regexes can also cause unexpected behavior. An innocent:
418
419 ok( $fileglob, '/path/to/some/*stuff/' );
420
421will fail since Test.pm considers the second argument to a regex.
422Again, best bet is to use the single argument form:
423
424 ok( $fileglob eq '/path/to/some/*stuff/' );
425
426
427=head1 TODO
428
429Add todo().
430
431Allow named tests.
432
433Implement noplan().
434
435
7b13a3f5 436=head1 SEE ALSO
437
809908f7 438L<Test::Simple>, L<Test::More>, L<Test::Harness>, L<Devel::Cover>
439
440L<Test::Unit> is an interesting alternative testing library.
441
edd5bad5 442L<Pod::Tests> and L<SelfTest> let you embed tests in code.
443
7b13a3f5 444
445=head1 AUTHOR
446
809908f7 447Copyright (c) 1998-2000 Joshua Nathaniel Pritikin. All rights reserved.
448Copyright (c) 2001 Michael G Schwern.
449
450Current maintainer, Michael G Schwern <schwern@pobox.com>
7b13a3f5 451
452This package is free software and is provided "as is" without express
453or implied warranty. It may be used, redistributed and/or modified
454under the terms of the Perl Artistic License (see
455http://www.perl.com/perl/misc/Artistic.html)
456
457=cut