Commit | Line | Data |
---|---|---|
809908f7 MS |
1 | |
2 | require 5.004; | |
75fa620a | 3 | package Test; |
ff56af3d | 4 | # Time-stamp: "2004-04-28 21:46:51 ADT" |
809908f7 MS |
5 | |
6 | use strict; | |
7 | ||
7b13a3f5 | 8 | use Carp; |
809908f7 | 9 | use vars (qw($VERSION @ISA @EXPORT @EXPORT_OK $ntest $TestLevel), #public-ish |
ff56af3d | 10 | qw($TESTOUT $TESTERR %Program_Lines $told_about_diff |
711cdd39 | 11 | $ONFAIL %todo %history $planned @FAILDETAIL) #private-ish |
809908f7 MS |
12 | ); |
13 | ||
711cdd39 MS |
14 | # In case a test is run in a persistent environment. |
15 | sub _reset_globals { | |
16 | %todo = (); | |
17 | %history = (); | |
18 | @FAILDETAIL = (); | |
19 | $ntest = 1; | |
20 | $TestLevel = 0; # how many extra stack frames to skip | |
21 | $planned = 0; | |
22 | } | |
23 | ||
ff56af3d | 24 | $VERSION = '1.25'; |
7b13a3f5 JP |
25 | require Exporter; |
26 | @ISA=('Exporter'); | |
809908f7 MS |
27 | |
28 | @EXPORT = qw(&plan &ok &skip); | |
711cdd39 | 29 | @EXPORT_OK = qw($ntest $TESTOUT $TESTERR); |
7b13a3f5 JP |
30 | |
31 | $|=1; | |
f2ac83ee | 32 | $TESTOUT = *STDOUT{IO}; |
711cdd39 | 33 | $TESTERR = *STDERR{IO}; |
7b13a3f5 | 34 | |
3238f5fe JP |
35 | # Use of this variable is strongly discouraged. It is set mainly to |
36 | # help test coverage analyzers know which test is running. | |
7b13a3f5 JP |
37 | $ENV{REGRESSION_TEST} = $0; |
38 | ||
809908f7 MS |
39 | |
40 | =head1 NAME | |
41 | ||
42 | Test - provides a simple framework for writing test scripts | |
43 | ||
44 | =head1 SYNOPSIS | |
45 | ||
46 | use strict; | |
47 | use Test; | |
48 | ||
49 | # use a BEGIN block so we print our plan before MyModule is loaded | |
50 | BEGIN { plan tests => 14, todo => [3,4] } | |
51 | ||
52 | # load your module... | |
53 | use MyModule; | |
54 | ||
75fa620a SB |
55 | # Helpful notes. All note-lines must start with a "#". |
56 | print "# I'm testing MyModule version $MyModule::VERSION\n"; | |
57 | ||
809908f7 MS |
58 | ok(0); # failure |
59 | ok(1); # success | |
60 | ||
61 | ok(0); # ok, expected failure (see todo list, above) | |
62 | ok(1); # surprise success! | |
63 | ||
64 | ok(0,1); # failure: '0' ne '1' | |
65 | ok('broke','fixed'); # failure: 'broke' ne 'fixed' | |
66 | ok('fixed','fixed'); # success: 'fixed' eq 'fixed' | |
67 | ok('fixed',qr/x/); # success: 'fixed' =~ qr/x/ | |
68 | ||
69 | ok(sub { 1+1 }, 2); # success: '2' eq '2' | |
70 | ok(sub { 1+1 }, 3); # failure: '2' ne '3' | |
809908f7 MS |
71 | |
72 | my @list = (0,0); | |
75fa620a | 73 | ok @list, 3, "\@list=".join(',',@list); #extra notes |
809908f7 MS |
74 | ok 'segmentation fault', '/(?i)success/'; #regex match |
75 | ||
75fa620a | 76 | skip( |
ff56af3d | 77 | $^O =~ m/MSWin/ ? "Skip if MSWin" : 0, # whether to skip |
26bf6773 HS |
78 | $foo, $bar # arguments just like for ok(...) |
79 | ); | |
80 | skip( | |
ff56af3d | 81 | $^O =~ m/MSWin/ ? 0 : "Skip unless MSWin", # whether to skip |
75fa620a SB |
82 | $foo, $bar # arguments just like for ok(...) |
83 | ); | |
809908f7 MS |
84 | |
85 | =head1 DESCRIPTION | |
86 | ||
75fa620a SB |
87 | This module simplifies the task of writing test files for Perl modules, |
88 | such that their output is in the format that | |
89 | L<Test::Harness|Test::Harness> expects to see. | |
edd5bad5 | 90 | |
75fa620a | 91 | =head1 QUICK START GUIDE |
809908f7 | 92 | |
75fa620a SB |
93 | To write a test for your new (and probably not even done) module, create |
94 | a new file called F<t/test.t> (in a new F<t> directory). If you have | |
95 | multiple test files, to test the "foo", "bar", and "baz" feature sets, | |
96 | then feel free to call your files F<t/foo.t>, F<t/bar.t>, and | |
97 | F<t/baz.t> | |
809908f7 MS |
98 | |
99 | =head2 Functions | |
100 | ||
75fa620a SB |
101 | This module defines three public functions, C<plan(...)>, C<ok(...)>, |
102 | and C<skip(...)>. By default, all three are exported by | |
103 | the C<use Test;> statement. | |
809908f7 MS |
104 | |
105 | =over 4 | |
106 | ||
75fa620a | 107 | =item C<plan(...)> |
809908f7 MS |
108 | |
109 | BEGIN { plan %theplan; } | |
110 | ||
111 | This should be the first thing you call in your test script. It | |
112 | declares your testing plan, how many there will be, if any of them | |
75fa620a | 113 | should be allowed to fail, and so on. |
809908f7 MS |
114 | |
115 | Typical usage is just: | |
116 | ||
117 | use Test; | |
118 | BEGIN { plan tests => 23 } | |
119 | ||
75fa620a SB |
120 | These are the things that you can put in the parameters to plan: |
121 | ||
122 | =over | |
123 | ||
124 | =item C<tests =E<gt> I<number>> | |
125 | ||
126 | The number of tests in your script. | |
127 | This means all ok() and skip() calls. | |
128 | ||
129 | =item C<todo =E<gt> [I<1,5,14>]> | |
130 | ||
131 | A reference to a list of tests which are allowed to fail. | |
132 | See L</TODO TESTS>. | |
133 | ||
134 | =item C<onfail =E<gt> sub { ... }> | |
809908f7 | 135 | |
75fa620a | 136 | =item C<onfail =E<gt> \&some_sub> |
809908f7 | 137 | |
75fa620a SB |
138 | A subroutine reference to be run at the end of the test script, if |
139 | any of the tests fail. See L</ONFAIL>. | |
140 | ||
141 | =back | |
142 | ||
143 | You must call C<plan(...)> once and only once. You should call it | |
144 | in a C<BEGIN {...}> block, like so: | |
145 | ||
146 | BEGIN { plan tests => 23 } | |
809908f7 MS |
147 | |
148 | =cut | |
149 | ||
7b13a3f5 JP |
150 | sub plan { |
151 | croak "Test::plan(%args): odd number of arguments" if @_ & 1; | |
8b3be1d1 | 152 | croak "Test::plan(): should not be called more than once" if $planned; |
809908f7 MS |
153 | |
154 | local($\, $,); # guard against -l and other things that screw with | |
155 | ||
156 | ||
711cdd39 MS |
157 | _reset_globals(); |
158 | ||
75fa620a SB |
159 | _read_program( (caller)[1] ); |
160 | ||
7b13a3f5 | 161 | my $max=0; |
ff56af3d AMS |
162 | while (@_) { |
163 | my ($k,$v) = splice(@_, 0, 2); | |
7b13a3f5 | 164 | if ($k =~ /^test(s)?$/) { $max = $v; } |
ff56af3d | 165 | elsif ($k eq 'todo' or |
7b13a3f5 | 166 | $k eq 'failok') { for (@$v) { $todo{$_}=1; }; } |
ff56af3d | 167 | elsif ($k eq 'onfail') { |
8b3be1d1 | 168 | ref $v eq 'CODE' or croak "Test::plan(onfail => $v): must be CODE"; |
ff56af3d | 169 | $ONFAIL = $v; |
8b3be1d1 | 170 | } |
7b13a3f5 JP |
171 | else { carp "Test::plan(): skipping unrecognized directive '$k'" } |
172 | } | |
173 | my @todo = sort { $a <=> $b } keys %todo; | |
174 | if (@todo) { | |
f2ac83ee | 175 | print $TESTOUT "1..$max todo ".join(' ', @todo).";\n"; |
7b13a3f5 | 176 | } else { |
f2ac83ee | 177 | print $TESTOUT "1..$max\n"; |
7b13a3f5 | 178 | } |
8b3be1d1 | 179 | ++$planned; |
75fa620a SB |
180 | print $TESTOUT "# Running under perl version $] for $^O", |
181 | (chr(65) eq 'A') ? "\n" : " in a non-ASCII world\n"; | |
182 | ||
183 | print $TESTOUT "# Win32::BuildNumber ", &Win32::BuildNumber(), "\n" | |
184 | if defined(&Win32::BuildNumber) and defined &Win32::BuildNumber(); | |
185 | ||
8d806c1c | 186 | print $TESTOUT "# MacPerl version $MacPerl::Version\n" |
75fa620a SB |
187 | if defined $MacPerl::Version; |
188 | ||
189 | printf $TESTOUT | |
190 | "# Current time local: %s\n# Current time GMT: %s\n", | |
26bf6773 | 191 | scalar(localtime($^T)), scalar(gmtime($^T)); |
ff56af3d | 192 | |
75fa620a | 193 | print $TESTOUT "# Using Test.pm version $VERSION\n"; |
809908f7 | 194 | |
75fa620a | 195 | # Retval never used: |
809908f7 | 196 | return undef; |
7b13a3f5 JP |
197 | } |
198 | ||
75fa620a SB |
199 | sub _read_program { |
200 | my($file) = shift; | |
201 | return unless defined $file and length $file | |
202 | and -e $file and -f _ and -r _; | |
203 | open(SOURCEFILE, "<$file") || return; | |
204 | $Program_Lines{$file} = [<SOURCEFILE>]; | |
205 | close(SOURCEFILE); | |
ff56af3d | 206 | |
75fa620a | 207 | foreach my $x (@{$Program_Lines{$file}}) |
8d806c1c | 208 | { $x =~ tr/\cm\cj\n\r//d } |
ff56af3d | 209 | |
75fa620a SB |
210 | unshift @{$Program_Lines{$file}}, ''; |
211 | return 1; | |
212 | } | |
809908f7 MS |
213 | |
214 | =begin _private | |
215 | ||
216 | =item B<_to_value> | |
217 | ||
218 | my $value = _to_value($input); | |
219 | ||
75fa620a | 220 | Converts an C<ok> parameter to its value. Typically this just means |
ff56af3d | 221 | running it, if it's a code reference. You should run all inputted |
809908f7 MS |
222 | values through this. |
223 | ||
224 | =cut | |
225 | ||
226 | sub _to_value { | |
3238f5fe | 227 | my ($v) = @_; |
ff56af3d | 228 | return ref $v eq 'CODE' ? $v->() : $v; |
3238f5fe JP |
229 | } |
230 | ||
ff56af3d AMS |
231 | sub _quote { |
232 | my $str = $_[0]; | |
233 | return "<UNDEF>" unless defined $str; | |
234 | $str =~ s/\\/\\\\/g; | |
235 | $str =~ s/"/\\"/g; | |
236 | $str =~ s/\a/\\a/g; | |
237 | $str =~ s/[\b]/\\b/g; | |
238 | $str =~ s/\e/\\e/g; | |
239 | $str =~ s/\f/\\f/g; | |
240 | $str =~ s/\n/\\n/g; | |
241 | $str =~ s/\r/\\r/g; | |
242 | $str =~ s/\t/\\t/g; | |
243 | $str =~ s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg; | |
244 | $str =~ s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg; | |
245 | $str =~ s/([^\0-\176])/sprintf('\\x{%X}',ord($1))/eg; | |
246 | #if( $_[1] ) { | |
247 | # substr( $str , 218-3 ) = "..." | |
248 | # if length($str) >= 218 and !$ENV{PERL_TEST_NO_TRUNC}; | |
249 | #} | |
250 | return qq("$str"); | |
251 | } | |
252 | ||
253 | ||
809908f7 MS |
254 | =end _private |
255 | ||
75fa620a | 256 | =item C<ok(...)> |
809908f7 MS |
257 | |
258 | ok(1 + 1 == 2); | |
259 | ok($have, $expect); | |
260 | ok($have, $expect, $diagnostics); | |
261 | ||
75fa620a SB |
262 | This function is the reason for C<Test>'s existence. It's |
263 | the basic function that | |
264 | handles printing "C<ok>" or "C<not ok>", along with the | |
265 | current test number. (That's what C<Test::Harness> wants to see.) | |
266 | ||
267 | In its most basic usage, C<ok(...)> simply takes a single scalar | |
268 | expression. If its value is true, the test passes; if false, | |
269 | the test fails. Examples: | |
809908f7 | 270 | |
75fa620a | 271 | # Examples of ok(scalar) |
809908f7 MS |
272 | |
273 | ok( 1 + 1 == 2 ); # ok if 1 + 1 == 2 | |
274 | ok( $foo =~ /bar/ ); # ok if $foo contains 'bar' | |
275 | ok( baz($x + $y) eq 'Armondo' ); # ok if baz($x + $y) returns | |
276 | # 'Armondo' | |
277 | ok( @a == @b ); # ok if @a and @b are the same length | |
278 | ||
279 | The expression is evaluated in scalar context. So the following will | |
280 | work: | |
281 | ||
282 | ok( @stuff ); # ok if @stuff has any elements | |
283 | ok( !grep !defined $_, @stuff ); # ok if everything in @stuff is | |
284 | # defined. | |
285 | ||
75fa620a SB |
286 | A special case is if the expression is a subroutine reference (in either |
287 | C<sub {...}> syntax or C<\&foo> syntax). In | |
809908f7 | 288 | that case, it is executed and its value (true or false) determines if |
75fa620a | 289 | the test passes or fails. For example, |
809908f7 | 290 | |
75fa620a SB |
291 | ok( sub { # See whether sleep works at least passably |
292 | my $start_time = time; | |
293 | sleep 5; | |
294 | time() - $start_time >= 4 | |
295 | }); | |
809908f7 | 296 | |
ff56af3d AMS |
297 | In its two-argument form, C<ok(I<arg1>, I<arg2>)> compares the two |
298 | scalar values to see if they match. They match if both are undefined, | |
299 | or if I<arg2> is a regex that matches I<arg1>, or if they compare equal | |
300 | with C<eq>. | |
809908f7 | 301 | |
75fa620a SB |
302 | # Example of ok(scalar, scalar) |
303 | ||
304 | ok( "this", "that" ); # not ok, 'this' ne 'that' | |
ff56af3d AMS |
305 | ok( "", undef ); # not ok, "" is defined |
306 | ||
307 | The second argument is considered a regex if it is either a regex | |
308 | object or a string that looks like a regex. Regex objects are | |
309 | constructed with the qr// operator in recent versions of perl. A | |
310 | string is considered to look like a regex if its first and last | |
311 | characters are "/", or if the first character is "m" | |
312 | and its second and last characters are both the | |
313 | same non-alphanumeric non-whitespace character. These regexp | |
314 | ||
315 | Regex examples: | |
316 | ||
317 | ok( 'JaffO', '/Jaff/' ); # ok, 'JaffO' =~ /Jaff/ | |
318 | ok( 'JaffO', 'm|Jaff|' ); # ok, 'JaffO' =~ m|Jaff| | |
319 | ok( 'JaffO', qr/Jaff/ ); # ok, 'JaffO' =~ qr/Jaff/; | |
320 | ok( 'JaffO', '/(?i)jaff/ ); # ok, 'JaffO' =~ /jaff/i; | |
809908f7 | 321 | |
75fa620a SB |
322 | If either (or both!) is a subroutine reference, it is run and used |
323 | as the value for comparing. For example: | |
324 | ||
ff56af3d | 325 | ok sub { |
75fa620a SB |
326 | open(OUT, ">x.dat") || die $!; |
327 | print OUT "\x{e000}"; | |
328 | close OUT; | |
329 | my $bytecount = -s 'x.dat'; | |
330 | unlink 'x.dat' or warn "Can't unlink : $!"; | |
331 | return $bytecount; | |
332 | }, | |
ff56af3d | 333 | 4 |
75fa620a SB |
334 | ; |
335 | ||
ff56af3d AMS |
336 | The above test passes two values to C<ok(arg1, arg2)> -- the first |
337 | a coderef, and the second is the number 4. Before C<ok> compares them, | |
75fa620a SB |
338 | it calls the coderef, and uses its return value as the real value of |
339 | this parameter. Assuming that C<$bytecount> returns 4, C<ok> ends up | |
ff56af3d | 340 | testing C<4 eq 4>. Since that's true, this test passes. |
809908f7 | 341 | |
ff56af3d | 342 | Finally, you can append an optional third argument, in |
75fa620a SB |
343 | C<ok(I<arg1>,I<arg2>, I<note>)>, where I<note> is a string value that |
344 | will be printed if the test fails. This should be some useful | |
345 | information about the test, pertaining to why it failed, and/or | |
346 | a description of the test. For example: | |
809908f7 MS |
347 | |
348 | ok( grep($_ eq 'something unique', @stuff), 1, | |
349 | "Something that should be unique isn't!\n". | |
350 | '@stuff = '.join ', ', @stuff | |
351 | ); | |
352 | ||
75fa620a SB |
353 | Unfortunately, a note cannot be used with the single argument |
354 | style of C<ok()>. That is, if you try C<ok(I<arg1>, I<note>)>, then | |
355 | C<Test> will interpret this as C<ok(I<arg1>, I<arg2>)>, and probably | |
356 | end up testing C<I<arg1> eq I<arg2>> -- and that's not what you want! | |
809908f7 | 357 | |
75fa620a SB |
358 | All of the above special cases can occasionally cause some |
359 | problems. See L</BUGS and CAVEATS>. | |
809908f7 MS |
360 | |
361 | =cut | |
362 | ||
75fa620a SB |
363 | # A past maintainer of this module said: |
364 | # <<ok(...)'s special handling of subroutine references is an unfortunate | |
365 | # "feature" that can't be removed due to compatibility.>> | |
366 | # | |
367 | ||
8b3be1d1 JP |
368 | sub ok ($;$$) { |
369 | croak "ok: plan before you test!" if !$planned; | |
809908f7 MS |
370 | |
371 | local($\,$,); # guard against -l and other things that screw with | |
372 | ||
373 | ||
3238f5fe JP |
374 | my ($pkg,$file,$line) = caller($TestLevel); |
375 | my $repetition = ++$history{"$file:$line"}; | |
376 | my $context = ("$file at line $line". | |
8b3be1d1 | 377 | ($repetition > 1 ? " fail \#$repetition" : '')); |
75fa620a | 378 | |
26bf6773 HS |
379 | # Are we comparing two values? |
380 | my $compare = 0; | |
381 | ||
3238f5fe | 382 | my $ok=0; |
809908f7 | 383 | my $result = _to_value(shift); |
ff56af3d | 384 | my ($expected, $isregex, $regex); |
3238f5fe | 385 | if (@_ == 0) { |
8b3be1d1 | 386 | $ok = $result; |
3238f5fe | 387 | } else { |
26bf6773 | 388 | $compare = 1; |
809908f7 | 389 | $expected = _to_value(shift); |
59e80644 JP |
390 | if (!defined $expected) { |
391 | $ok = !defined $result; | |
392 | } elsif (!defined $result) { | |
393 | $ok = 0; | |
ff56af3d | 394 | } elsif (ref($expected) eq 'Regexp') { |
f2ac83ee | 395 | $ok = $result =~ /$expected/; |
809908f7 | 396 | $regex = $expected; |
f2ac83ee | 397 | } elsif (($regex) = ($expected =~ m,^ / (.+) / $,sx) or |
809908f7 | 398 | (undef, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) { |
8b3be1d1 | 399 | $ok = $result =~ /$regex/; |
3238f5fe | 400 | } else { |
3238f5fe JP |
401 | $ok = $result eq $expected; |
402 | } | |
8b3be1d1 | 403 | } |
f2ac83ee GS |
404 | my $todo = $todo{$ntest}; |
405 | if ($todo and $ok) { | |
406 | $context .= ' TODO?!' if $todo; | |
407 | print $TESTOUT "ok $ntest # ($context)\n"; | |
8b3be1d1 | 408 | } else { |
809908f7 MS |
409 | # Issuing two seperate prints() causes problems on VMS. |
410 | if (!$ok) { | |
411 | print $TESTOUT "not ok $ntest\n"; | |
e5420382 | 412 | } |
809908f7 MS |
413 | else { |
414 | print $TESTOUT "ok $ntest\n"; | |
e5420382 | 415 | } |
75fa620a | 416 | |
ff56af3d AMS |
417 | $ok or _complain($result, $expected, |
418 | { | |
419 | 'repetition' => $repetition, 'package' => $pkg, | |
420 | 'result' => $result, 'todo' => $todo, | |
421 | 'file' => $file, 'line' => $line, | |
422 | 'context' => $context, 'compare' => $compare, | |
423 | @_ ? ('diagnostic' => _to_value(shift)) : (), | |
424 | }); | |
425 | ||
7b13a3f5 JP |
426 | } |
427 | ++ $ntest; | |
428 | $ok; | |
429 | } | |
430 | ||
ff56af3d AMS |
431 | |
432 | sub _complain { | |
433 | my($result, $expected, $detail) = @_; | |
434 | $$detail{expected} = $expected if defined $expected; | |
435 | ||
436 | # Get the user's diagnostic, protecting against multi-line | |
437 | # diagnostics. | |
438 | my $diag = $$detail{diagnostic}; | |
439 | $diag =~ s/\n/\n#/g if defined $diag; | |
440 | ||
441 | $$detail{context} .= ' *TODO*' if $$detail{todo}; | |
442 | if (!$$detail{compare}) { | |
443 | if (!$diag) { | |
444 | print $TESTERR "# Failed test $ntest in $$detail{context}\n"; | |
445 | } else { | |
446 | print $TESTERR "# Failed test $ntest in $$detail{context}: $diag\n"; | |
447 | } | |
448 | } else { | |
449 | my $prefix = "Test $ntest"; | |
450 | ||
451 | print $TESTERR "# $prefix got: " . _quote($result) . | |
452 | " ($$detail{context})\n"; | |
453 | $prefix = ' ' x (length($prefix) - 5); | |
454 | my $expected_quoted = (defined $$detail{regex}) | |
455 | ? 'qr{'.($$detail{regex}).'}' : _quote($expected); | |
456 | ||
457 | print $TESTERR "# $prefix Expected: $expected_quoted", | |
458 | $diag ? " ($diag)" : (), "\n"; | |
459 | ||
460 | _diff_complain( $result, $expected, $detail, $prefix ) | |
461 | if defined($expected) and 2 < ($expected =~ tr/\n//); | |
462 | } | |
463 | ||
464 | if(defined $Program_Lines{ $$detail{file} }[ $$detail{line} ]) { | |
465 | print $TESTERR | |
466 | "# $$detail{file} line $$detail{line} is: $Program_Lines{ $$detail{file} }[ $$detail{line} ]\n" | |
467 | if $Program_Lines{ $$detail{file} }[ $$detail{line} ] | |
468 | =~ m/[^\s\#\(\)\{\}\[\]\;]/; # Otherwise it's uninformative | |
469 | ||
470 | undef $Program_Lines{ $$detail{file} }[ $$detail{line} ]; | |
471 | # So we won't repeat it. | |
472 | } | |
473 | ||
474 | push @FAILDETAIL, $detail; | |
475 | return; | |
476 | } | |
477 | ||
478 | ||
479 | ||
480 | sub _diff_complain { | |
481 | my($result, $expected, $detail, $prefix) = @_; | |
482 | return _diff_complain_external(@_) if $ENV{PERL_TEST_DIFF}; | |
483 | return _diff_complain_algdiff(@_) | |
484 | if eval { require Algorithm::Diff; Algorithm::Diff->VERSION(1.15); 1; }; | |
485 | ||
486 | $told_about_diff++ or print $TESTERR <<"EOT"; | |
487 | # $prefix (Install the Algorithm::Diff module to have differences in multiline | |
488 | # $prefix output explained. You might also set the PERL_TEST_DIFF environment | |
489 | # $prefix variable to run a diff program on the output.) | |
490 | EOT | |
491 | ; | |
492 | return; | |
493 | } | |
494 | ||
495 | ||
496 | ||
497 | sub _diff_complain_external { | |
498 | my($result, $expected, $detail, $prefix) = @_; | |
499 | my $diff = $ENV{PERL_TEST_DIFF} || die "WHAAAA?"; | |
500 | ||
501 | require File::Temp; | |
502 | my($got_fh, $got_filename) = File::Temp::tempfile("test-got-XXXXX"); | |
503 | my($exp_fh, $exp_filename) = File::Temp::tempfile("test-exp-XXXXX"); | |
504 | unless ($got_fh && $exp_fh) { | |
505 | warn "Can't get tempfiles"; | |
506 | return; | |
507 | } | |
508 | ||
509 | print $got_fh $result; | |
510 | print $exp_fh $expected; | |
511 | if (close($got_fh) && close($exp_fh)) { | |
512 | my $diff_cmd = "$diff $exp_filename $got_filename"; | |
513 | print $TESTERR "#\n# $prefix $diff_cmd\n"; | |
514 | if (open(DIFF, "$diff_cmd |")) { | |
515 | local $_; | |
516 | while (<DIFF>) { | |
517 | print $TESTERR "# $prefix $_"; | |
518 | } | |
519 | close(DIFF); | |
520 | } | |
521 | else { | |
522 | warn "Can't run diff: $!"; | |
523 | } | |
524 | } else { | |
525 | warn "Can't write to tempfiles: $!"; | |
526 | } | |
527 | unlink($got_filename); | |
528 | unlink($exp_filename); | |
529 | return; | |
530 | } | |
531 | ||
532 | ||
533 | ||
534 | sub _diff_complain_algdiff { | |
535 | my($result, $expected, $detail, $prefix) = @_; | |
536 | ||
537 | my @got = split(/^/, $result); | |
538 | my @exp = split(/^/, $expected); | |
539 | ||
540 | my $diff_kind; | |
541 | my @diff_lines; | |
542 | ||
543 | my $diff_flush = sub { | |
544 | return unless $diff_kind; | |
545 | ||
546 | my $count_lines = @diff_lines; | |
547 | my $s = $count_lines == 1 ? "" : "s"; | |
548 | my $first_line = $diff_lines[0][0] + 1; | |
549 | ||
550 | print $TESTERR "# $prefix "; | |
551 | if ($diff_kind eq "GOT") { | |
552 | print $TESTERR "Got $count_lines extra line$s at line $first_line:\n"; | |
553 | for my $i (@diff_lines) { | |
554 | print $TESTERR "# $prefix + " . _quote($got[$i->[0]]) . "\n"; | |
555 | } | |
556 | } elsif ($diff_kind eq "EXP") { | |
557 | if ($count_lines > 1) { | |
558 | my $last_line = $diff_lines[-1][0] + 1; | |
559 | print $TESTERR "Lines $first_line-$last_line are"; | |
560 | } | |
561 | else { | |
562 | print $TESTERR "Line $first_line is"; | |
563 | } | |
564 | print $TESTERR " missing:\n"; | |
565 | for my $i (@diff_lines) { | |
566 | print $TESTERR "# $prefix - " . _quote($exp[$i->[1]]) . "\n"; | |
567 | } | |
568 | } elsif ($diff_kind eq "CH") { | |
569 | if ($count_lines > 1) { | |
570 | my $last_line = $diff_lines[-1][0] + 1; | |
571 | print $TESTERR "Lines $first_line-$last_line are"; | |
572 | } | |
573 | else { | |
574 | print $TESTERR "Line $first_line is"; | |
575 | } | |
576 | print $TESTERR " changed:\n"; | |
577 | for my $i (@diff_lines) { | |
578 | print $TESTERR "# $prefix - " . _quote($exp[$i->[1]]) . "\n"; | |
579 | print $TESTERR "# $prefix + " . _quote($got[$i->[0]]) . "\n"; | |
580 | } | |
581 | } | |
582 | ||
583 | # reset | |
584 | $diff_kind = undef; | |
585 | @diff_lines = (); | |
586 | }; | |
587 | ||
588 | my $diff_collect = sub { | |
589 | my $kind = shift; | |
590 | &$diff_flush() if $diff_kind && $diff_kind ne $kind; | |
591 | $diff_kind = $kind; | |
592 | push(@diff_lines, [@_]); | |
593 | }; | |
594 | ||
595 | ||
596 | Algorithm::Diff::traverse_balanced( | |
597 | \@got, \@exp, | |
598 | { | |
599 | DISCARD_A => sub { &$diff_collect("GOT", @_) }, | |
600 | DISCARD_B => sub { &$diff_collect("EXP", @_) }, | |
601 | CHANGE => sub { &$diff_collect("CH", @_) }, | |
602 | MATCH => sub { &$diff_flush() }, | |
603 | }, | |
604 | ); | |
605 | &$diff_flush(); | |
606 | ||
607 | return; | |
608 | } | |
609 | ||
610 | ||
611 | ||
612 | ||
613 | #~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~ | |
614 | ||
615 | ||
75fa620a SB |
616 | =item C<skip(I<skip_if_true>, I<args...>)> |
617 | ||
618 | This is used for tests that under some conditions can be skipped. It's | |
619 | basically equivalent to: | |
620 | ||
621 | if( $skip_if_true ) { | |
622 | ok(1); | |
623 | } else { | |
624 | ok( args... ); | |
625 | } | |
626 | ||
627 | ...except that the C<ok(1)> emits not just "C<ok I<testnum>>" but | |
628 | actually "C<ok I<testnum> # I<skip_if_true_value>>". | |
629 | ||
630 | The arguments after the I<skip_if_true> are what is fed to C<ok(...)> if | |
631 | this test isn't skipped. | |
632 | ||
633 | Example usage: | |
634 | ||
635 | my $if_MSWin = | |
ff56af3d | 636 | $^O =~ m/MSWin/ ? 'Skip if under MSWin' : ''; |
75fa620a | 637 | |
ff56af3d | 638 | # A test to be skipped if under MSWin (i.e., run except under MSWin) |
75fa620a SB |
639 | skip($if_MSWin, thing($foo), thing($bar) ); |
640 | ||
ff56af3d | 641 | Or, going the other way: |
75fa620a SB |
642 | |
643 | my $unless_MSWin = | |
ff56af3d | 644 | $^O =~ m/MSWin/ ? '' : 'Skip unless under MSWin'; |
75fa620a | 645 | |
ff56af3d | 646 | # A test to be skipped unless under MSWin (i.e., run only under MSWin) |
75fa620a SB |
647 | skip($unless_MSWin, thing($foo), thing($bar) ); |
648 | ||
26bf6773 | 649 | The tricky thing to remember is that the first parameter is true if |
75fa620a SB |
650 | you want to I<skip> the test, not I<run> it; and it also doubles as a |
651 | note about why it's being skipped. So in the first codeblock above, read | |
652 | the code as "skip if MSWin -- (otherwise) test whether C<thing($foo)> is | |
653 | C<thing($bar)>" or for the second case, "skip unless MSWin...". | |
654 | ||
655 | Also, when your I<skip_if_reason> string is true, it really should (for | |
656 | backwards compatibility with older Test.pm versions) start with the | |
657 | string "Skip", as shown in the above examples. | |
658 | ||
659 | Note that in the above cases, C<thing($foo)> and C<thing($bar)> | |
660 | I<are> evaluated -- but as long as the C<skip_if_true> is true, | |
661 | then we C<skip(...)> just tosses out their value (i.e., not | |
662 | bothering to treat them like values to C<ok(...)>. But if | |
663 | you need to I<not> eval the arguments when skipping the | |
664 | test, use | |
665 | this format: | |
666 | ||
667 | skip( $unless_MSWin, | |
668 | sub { | |
669 | # This code returns true if the test passes. | |
670 | # (But it doesn't even get called if the test is skipped.) | |
671 | thing($foo) eq thing($bar) | |
672 | } | |
673 | ); | |
674 | ||
675 | or even this, which is basically equivalent: | |
676 | ||
677 | skip( $unless_MSWin, | |
678 | sub { thing($foo) }, sub { thing($bar) } | |
679 | ); | |
680 | ||
681 | That is, both are like this: | |
682 | ||
683 | if( $unless_MSWin ) { | |
684 | ok(1); # but it actually appends "# $unless_MSWin" | |
685 | # so that Test::Harness can tell it's a skip | |
686 | } else { | |
687 | # Not skipping, so actually call and evaluate... | |
688 | ok( sub { thing($foo) }, sub { thing($bar) } ); | |
689 | } | |
690 | ||
691 | =cut | |
692 | ||
809908f7 MS |
693 | sub skip ($;$$$) { |
694 | local($\, $,); # guard against -l and other things that screw with | |
695 | ||
696 | ||
697 | my $whyskip = _to_value(shift); | |
698 | if (!@_ or $whyskip) { | |
699 | $whyskip = '' if $whyskip =~ m/^\d+$/; | |
700 | $whyskip =~ s/^[Ss]kip(?:\s+|$)//; # backwards compatibility, old | |
701 | # versions required the reason | |
702 | # to start with 'skip' | |
703 | # We print in one shot for VMSy reasons. | |
704 | my $ok = "ok $ntest # skip"; | |
705 | $ok .= " $whyskip" if length $whyskip; | |
706 | $ok .= "\n"; | |
707 | print $TESTOUT $ok; | |
708 | ++ $ntest; | |
709 | return 1; | |
7b13a3f5 | 710 | } else { |
3c4b39be | 711 | # backwards compatibility (I think). skip() used to be |
316cf57b MS |
712 | # called like ok(), which is weird. I haven't decided what to do with |
713 | # this yet. | |
714 | # warn <<WARN if $^W; | |
715 | #This looks like a skip() using the very old interface. Please upgrade to | |
716 | #the documented interface as this has been deprecated. | |
717 | #WARN | |
809908f7 | 718 | |
75fa620a | 719 | local($TestLevel) = $TestLevel+1; #to ignore this stack frame |
809908f7 | 720 | return &ok(@_); |
7b13a3f5 JP |
721 | } |
722 | } | |
723 | ||
809908f7 MS |
724 | =back |
725 | ||
726 | =cut | |
727 | ||
8b3be1d1 JP |
728 | END { |
729 | $ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL; | |
730 | } | |
731 | ||
7b13a3f5 JP |
732 | 1; |
733 | __END__ | |
734 | ||
3238f5fe | 735 | =head1 TEST TYPES |
7b13a3f5 JP |
736 | |
737 | =over 4 | |
738 | ||
739 | =item * NORMAL TESTS | |
740 | ||
75fa620a SB |
741 | These tests are expected to succeed. Usually, most or all of your tests |
742 | are in this category. If a normal test doesn't succeed, then that | |
ff56af3d | 743 | means that something is I<wrong>. |
7b13a3f5 JP |
744 | |
745 | =item * SKIPPED TESTS | |
746 | ||
75fa620a SB |
747 | The C<skip(...)> function is for tests that might or might not be |
748 | possible to run, depending | |
749 | on the availability of platform-specific features. The first argument | |
f2ac83ee | 750 | should evaluate to true (think "yes, please skip") if the required |
75fa620a SB |
751 | feature is I<not> available. After the first argument, C<skip(...)> works |
752 | exactly the same way as C<ok(...)> does. | |
7b13a3f5 JP |
753 | |
754 | =item * TODO TESTS | |
755 | ||
f2ac83ee | 756 | TODO tests are designed for maintaining an B<executable TODO list>. |
75fa620a SB |
757 | These tests are I<expected to fail.> If a TODO test does succeed, |
758 | then the feature in question shouldn't be on the TODO list, now | |
759 | should it? | |
7b13a3f5 | 760 | |
f2ac83ee | 761 | Packages should NOT be released with succeeding TODO tests. As soon |
75fa620a | 762 | as a TODO test starts working, it should be promoted to a normal test, |
f2ac83ee | 763 | and the newly working feature should be documented in the release |
75fa620a | 764 | notes or in the change log. |
7b13a3f5 JP |
765 | |
766 | =back | |
767 | ||
8b3be1d1 JP |
768 | =head1 ONFAIL |
769 | ||
770 | BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } } | |
771 | ||
75fa620a | 772 | Although test failures should be enough, extra diagnostics can be |
f2ac83ee GS |
773 | triggered at the end of a test run. C<onfail> is passed an array ref |
774 | of hash refs that describe each test failure. Each hash will contain | |
775 | at least the following fields: C<package>, C<repetition>, and | |
ff56af3d | 776 | C<result>. (You shouldn't rely on any other fields being present.) If the test |
75fa620a | 777 | had an expected value or a diagnostic (or "note") string, these will also be |
f2ac83ee GS |
778 | included. |
779 | ||
75fa620a | 780 | The I<optional> C<onfail> hook might be used simply to print out the |
f2ac83ee GS |
781 | version of your package and/or how to report problems. It might also |
782 | be used to generate extremely sophisticated diagnostics for a | |
783 | particularly bizarre test failure. However it's not a panacea. Core | |
784 | dumps or other unrecoverable errors prevent the C<onfail> hook from | |
785 | running. (It is run inside an C<END> block.) Besides, C<onfail> is | |
786 | probably over-kill in most cases. (Your test code should be simpler | |
8b3be1d1 JP |
787 | than the code it is testing, yes?) |
788 | ||
809908f7 MS |
789 | |
790 | =head1 BUGS and CAVEATS | |
791 | ||
75fa620a SB |
792 | =over |
793 | ||
794 | =item * | |
795 | ||
796 | C<ok(...)>'s special handing of strings which look like they might be | |
797 | regexes can also cause unexpected behavior. An innocent: | |
798 | ||
799 | ok( $fileglob, '/path/to/some/*stuff/' ); | |
800 | ||
801 | will fail, since Test.pm considers the second argument to be a regex! | |
802 | The best bet is to use the one-argument form: | |
803 | ||
804 | ok( $fileglob eq '/path/to/some/*stuff/' ); | |
809908f7 | 805 | |
75fa620a SB |
806 | =item * |
807 | ||
808 | C<ok(...)>'s use of string C<eq> can sometimes cause odd problems | |
809 | when comparing | |
809908f7 MS |
810 | numbers, especially if you're casting a string to a number: |
811 | ||
812 | $foo = "1.0"; | |
813 | ok( $foo, 1 ); # not ok, "1.0" ne 1 | |
814 | ||
815 | Your best bet is to use the single argument form: | |
816 | ||
817 | ok( $foo == 1 ); # ok "1.0" == 1 | |
818 | ||
75fa620a | 819 | =item * |
809908f7 | 820 | |
75fa620a SB |
821 | As you may have inferred from the above documentation and examples, |
822 | C<ok>'s prototype is C<($;$$)> (and, incidentally, C<skip>'s is | |
823 | C<($;$$$)>). This means, for example, that you can do C<ok @foo, @bar> | |
824 | to compare the I<size> of the two arrays. But don't be fooled into | |
825 | thinking that C<ok @foo, @bar> means a comparison of the contents of two | |
826 | arrays -- you're comparing I<just> the number of elements of each. It's | |
827 | so easy to make that mistake in reading C<ok @foo, @bar> that you might | |
828 | want to be very explicit about it, and instead write C<ok scalar(@foo), | |
829 | scalar(@bar)>. | |
809908f7 | 830 | |
26bf6773 HS |
831 | =item * |
832 | ||
833 | This almost definitely doesn't do what you expect: | |
834 | ||
835 | ok $thingy->can('some_method'); | |
836 | ||
837 | Why? Because C<can> returns a coderef to mean "yes it can (and the | |
838 | method is this...)", and then C<ok> sees a coderef and thinks you're | |
839 | passing a function that you want it to call and consider the truth of | |
840 | the result of! I.e., just like: | |
841 | ||
842 | ok $thingy->can('some_method')->(); | |
843 | ||
844 | What you probably want instead is this: | |
845 | ||
846 | ok $thingy->can('some_method') && 1; | |
847 | ||
848 | If the C<can> returns false, then that is passed to C<ok>. If it | |
849 | returns true, then the larger expression S<< C<< | |
850 | $thingy->can('some_method') && 1 >> >> returns 1, which C<ok> sees as | |
851 | a simple signal of success, as you would expect. | |
852 | ||
853 | ||
854 | =item * | |
855 | ||
856 | The syntax for C<skip> is about the only way it can be, but it's still | |
857 | quite confusing. Just start with the above examples and you'll | |
858 | be okay. | |
859 | ||
860 | Moreover, users may expect this: | |
861 | ||
862 | skip $unless_mswin, foo($bar), baz($quux); | |
863 | ||
864 | to not evaluate C<foo($bar)> and C<baz($quux)> when the test is being | |
865 | skipped. But in reality, they I<are> evaluated, but C<skip> just won't | |
866 | bother comparing them if C<$unless_mswin> is true. | |
867 | ||
868 | You could do this: | |
869 | ||
870 | skip $unless_mswin, sub{foo($bar)}, sub{baz($quux)}; | |
871 | ||
872 | But that's not terribly pretty. You may find it simpler or clearer in | |
873 | the long run to just do things like this: | |
874 | ||
875 | if( $^O =~ m/MSWin/ ) { | |
876 | print "# Yay, we're under $^O\n"; | |
877 | ok foo($bar), baz($quux); | |
878 | ok thing($whatever), baz($stuff); | |
879 | ok blorp($quux, $whatever); | |
880 | ok foo($barzbarz), thang($quux); | |
881 | } else { | |
882 | print "# Feh, we're under $^O. Watch me skip some tests...\n"; | |
883 | for(1 .. 4) { skip "Skip unless under MSWin" } | |
884 | } | |
885 | ||
886 | But be quite sure that C<ok> is called exactly as many times in the | |
887 | first block as C<skip> is called in the second block. | |
888 | ||
75fa620a | 889 | =back |
809908f7 | 890 | |
ff56af3d AMS |
891 | |
892 | =head1 ENVIRONMENT | |
893 | ||
894 | If C<PERL_TEST_DIFF> environment variable is set, it will be used as a | |
895 | command for comparing unexpected multiline results. If you have GNU | |
896 | diff installed, you might want to set C<PERL_TEST_DIFF> to C<diff -u>. | |
897 | If you don't have a suitable program, you might install the | |
898 | C<Text::Diff> module and then set C<PERL_TEST_DIFF> to be C<perl | |
899 | -MText::Diff -e 'print diff(@ARGV)'>. If C<PERL_TEST_DIFF> isn't set | |
900 | but the C<Algorithm::Diff> module is available, then it will be used | |
901 | to show the differences in multiline results. | |
902 | ||
903 | =for comment | |
904 | If C<PERL_TEST_NO_TRUNC> is set, then the initial "Got 'something' but | |
905 | expected 'something_else'" readings for long multiline output values aren't | |
906 | truncated at about the 230th column, as they normally could be in some | |
907 | cases. Normally you won't need to use this, unless you were carefully | |
908 | parsing the output of your test programs. | |
909 | ||
910 | ||
711cdd39 | 911 | =head1 NOTE |
809908f7 | 912 | |
75fa620a SB |
913 | A past developer of this module once said that it was no longer being |
914 | actively developed. However, rumors of its demise were greatly | |
915 | exaggerated. Feedback and suggestions are quite welcome. | |
916 | ||
917 | Be aware that the main value of this module is its simplicity. Note | |
918 | that there are already more ambitious modules out there, such as | |
919 | L<Test::More> and L<Test::Unit>. | |
809908f7 | 920 | |
ff56af3d | 921 | Some earlier versions of this module had docs with some confusing |
3c4b39be | 922 | typos in the description of C<skip(...)>. |
ff56af3d | 923 | |
809908f7 | 924 | |
7b13a3f5 JP |
925 | =head1 SEE ALSO |
926 | ||
75fa620a SB |
927 | L<Test::Harness> |
928 | ||
929 | L<Test::Simple>, L<Test::More>, L<Devel::Cover> | |
809908f7 | 930 | |
711cdd39 MS |
931 | L<Test::Builder> for building your own testing library. |
932 | ||
933 | L<Test::Unit> is an interesting XUnit-style testing library. | |
809908f7 | 934 | |
711cdd39 | 935 | L<Test::Inline> and L<SelfTest> let you embed tests in code. |
edd5bad5 | 936 | |
7b13a3f5 JP |
937 | |
938 | =head1 AUTHOR | |
939 | ||
809908f7 | 940 | Copyright (c) 1998-2000 Joshua Nathaniel Pritikin. All rights reserved. |
809908f7 | 941 | |
75fa620a SB |
942 | Copyright (c) 2001-2002 Michael G. Schwern. |
943 | ||
ff56af3d | 944 | Copyright (c) 2002-2004 and counting Sean M. Burke. |
75fa620a SB |
945 | |
946 | Current maintainer: Sean M. Burke. E<lt>sburke@cpan.orgE<gt> | |
7b13a3f5 JP |
947 | |
948 | This package is free software and is provided "as is" without express | |
949 | or implied warranty. It may be used, redistributed and/or modified | |
711cdd39 | 950 | under the same terms as Perl itself. |
7b13a3f5 JP |
951 | |
952 | =cut | |
75fa620a SB |
953 | |
954 | # "Your mistake was a hidden intention." | |
955 | # -- /Oblique Strategies/, Brian Eno and Peter Schmidt |