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