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