1 |
|
---|
2 | require 5.004;
|
---|
3 | package Test;
|
---|
4 | # Time-stamp: "2004-04-28 21:46:51 ADT"
|
---|
5 |
|
---|
6 | use strict;
|
---|
7 |
|
---|
8 | use Carp;
|
---|
9 | use vars (qw($VERSION @ISA @EXPORT @EXPORT_OK $ntest $TestLevel), #public-ish
|
---|
10 | qw($TESTOUT $TESTERR %Program_Lines $told_about_diff
|
---|
11 | $ONFAIL %todo %history $planned @FAILDETAIL) #private-ish
|
---|
12 | );
|
---|
13 |
|
---|
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 |
|
---|
24 | $VERSION = '1.25';
|
---|
25 | require Exporter;
|
---|
26 | @ISA=('Exporter');
|
---|
27 |
|
---|
28 | @EXPORT = qw(&plan &ok &skip);
|
---|
29 | @EXPORT_OK = qw($ntest $TESTOUT $TESTERR);
|
---|
30 |
|
---|
31 | $|=1;
|
---|
32 | $TESTOUT = *STDOUT{IO};
|
---|
33 | $TESTERR = *STDERR{IO};
|
---|
34 |
|
---|
35 | # Use of this variable is strongly discouraged. It is set mainly to
|
---|
36 | # help test coverage analyzers know which test is running.
|
---|
37 | $ENV{REGRESSION_TEST} = $0;
|
---|
38 |
|
---|
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 |
|
---|
55 | # Helpful notes. All note-lines must start with a "#".
|
---|
56 | print "# I'm testing MyModule version $MyModule::VERSION\n";
|
---|
57 |
|
---|
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'
|
---|
71 |
|
---|
72 | my @list = (0,0);
|
---|
73 | ok @list, 3, "\@list=".join(',',@list); #extra notes
|
---|
74 | ok 'segmentation fault', '/(?i)success/'; #regex match
|
---|
75 |
|
---|
76 | skip(
|
---|
77 | $^O =~ m/MSWin/ ? "Skip if MSWin" : 0, # whether to skip
|
---|
78 | $foo, $bar # arguments just like for ok(...)
|
---|
79 | );
|
---|
80 | skip(
|
---|
81 | $^O =~ m/MSWin/ ? 0 : "Skip unless MSWin", # whether to skip
|
---|
82 | $foo, $bar # arguments just like for ok(...)
|
---|
83 | );
|
---|
84 |
|
---|
85 | =head1 DESCRIPTION
|
---|
86 |
|
---|
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.
|
---|
90 |
|
---|
91 | =head1 QUICK START GUIDE
|
---|
92 |
|
---|
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>
|
---|
98 |
|
---|
99 | =head2 Functions
|
---|
100 |
|
---|
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.
|
---|
104 |
|
---|
105 | =over 4
|
---|
106 |
|
---|
107 | =item C<plan(...)>
|
---|
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
|
---|
113 | should be allowed to fail, and so on.
|
---|
114 |
|
---|
115 | Typical usage is just:
|
---|
116 |
|
---|
117 | use Test;
|
---|
118 | BEGIN { plan tests => 23 }
|
---|
119 |
|
---|
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 { ... }>
|
---|
135 |
|
---|
136 | =item C<onfail =E<gt> \&some_sub>
|
---|
137 |
|
---|
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 }
|
---|
147 |
|
---|
148 | =cut
|
---|
149 |
|
---|
150 | sub plan {
|
---|
151 | croak "Test::plan(%args): odd number of arguments" if @_ & 1;
|
---|
152 | croak "Test::plan(): should not be called more than once" if $planned;
|
---|
153 |
|
---|
154 | local($\, $,); # guard against -l and other things that screw with
|
---|
155 | # print
|
---|
156 |
|
---|
157 | _reset_globals();
|
---|
158 |
|
---|
159 | _read_program( (caller)[1] );
|
---|
160 |
|
---|
161 | my $max=0;
|
---|
162 | while (@_) {
|
---|
163 | my ($k,$v) = splice(@_, 0, 2);
|
---|
164 | if ($k =~ /^test(s)?$/) { $max = $v; }
|
---|
165 | elsif ($k eq 'todo' or
|
---|
166 | $k eq 'failok') { for (@$v) { $todo{$_}=1; }; }
|
---|
167 | elsif ($k eq 'onfail') {
|
---|
168 | ref $v eq 'CODE' or croak "Test::plan(onfail => $v): must be CODE";
|
---|
169 | $ONFAIL = $v;
|
---|
170 | }
|
---|
171 | else { carp "Test::plan(): skipping unrecognized directive '$k'" }
|
---|
172 | }
|
---|
173 | my @todo = sort { $a <=> $b } keys %todo;
|
---|
174 | if (@todo) {
|
---|
175 | print $TESTOUT "1..$max todo ".join(' ', @todo).";\n";
|
---|
176 | } else {
|
---|
177 | print $TESTOUT "1..$max\n";
|
---|
178 | }
|
---|
179 | ++$planned;
|
---|
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 |
|
---|
186 | print $TESTOUT "# MacPerl version $MacPerl::Version\n"
|
---|
187 | if defined $MacPerl::Version;
|
---|
188 |
|
---|
189 | printf $TESTOUT
|
---|
190 | "# Current time local: %s\n# Current time GMT: %s\n",
|
---|
191 | scalar(localtime($^T)), scalar(gmtime($^T));
|
---|
192 |
|
---|
193 | print $TESTOUT "# Using Test.pm version $VERSION\n";
|
---|
194 |
|
---|
195 | # Retval never used:
|
---|
196 | return undef;
|
---|
197 | }
|
---|
198 |
|
---|
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);
|
---|
206 |
|
---|
207 | foreach my $x (@{$Program_Lines{$file}})
|
---|
208 | { $x =~ tr/\cm\cj\n\r//d }
|
---|
209 |
|
---|
210 | unshift @{$Program_Lines{$file}}, '';
|
---|
211 | return 1;
|
---|
212 | }
|
---|
213 |
|
---|
214 | =begin _private
|
---|
215 |
|
---|
216 | =item B<_to_value>
|
---|
217 |
|
---|
218 | my $value = _to_value($input);
|
---|
219 |
|
---|
220 | Converts an C<ok> parameter to its value. Typically this just means
|
---|
221 | running it, if it's a code reference. You should run all inputted
|
---|
222 | values through this.
|
---|
223 |
|
---|
224 | =cut
|
---|
225 |
|
---|
226 | sub _to_value {
|
---|
227 | my ($v) = @_;
|
---|
228 | return ref $v eq 'CODE' ? $v->() : $v;
|
---|
229 | }
|
---|
230 |
|
---|
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 |
|
---|
254 | =end _private
|
---|
255 |
|
---|
256 | =item C<ok(...)>
|
---|
257 |
|
---|
258 | ok(1 + 1 == 2);
|
---|
259 | ok($have, $expect);
|
---|
260 | ok($have, $expect, $diagnostics);
|
---|
261 |
|
---|
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:
|
---|
270 |
|
---|
271 | # Examples of ok(scalar)
|
---|
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 |
|
---|
286 | A special case is if the expression is a subroutine reference (in either
|
---|
287 | C<sub {...}> syntax or C<\&foo> syntax). In
|
---|
288 | that case, it is executed and its value (true or false) determines if
|
---|
289 | the test passes or fails. For example,
|
---|
290 |
|
---|
291 | ok( sub { # See whether sleep works at least passably
|
---|
292 | my $start_time = time;
|
---|
293 | sleep 5;
|
---|
294 | time() - $start_time >= 4
|
---|
295 | });
|
---|
296 |
|
---|
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>.
|
---|
301 |
|
---|
302 | # Example of ok(scalar, scalar)
|
---|
303 |
|
---|
304 | ok( "this", "that" ); # not ok, 'this' ne 'that'
|
---|
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;
|
---|
321 |
|
---|
322 | If either (or both!) is a subroutine reference, it is run and used
|
---|
323 | as the value for comparing. For example:
|
---|
324 |
|
---|
325 | ok sub {
|
---|
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 | },
|
---|
333 | 4
|
---|
334 | ;
|
---|
335 |
|
---|
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,
|
---|
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
|
---|
340 | testing C<4 eq 4>. Since that's true, this test passes.
|
---|
341 |
|
---|
342 | Finally, you can append an optional third argument, in
|
---|
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:
|
---|
347 |
|
---|
348 | ok( grep($_ eq 'something unique', @stuff), 1,
|
---|
349 | "Something that should be unique isn't!\n".
|
---|
350 | '@stuff = '.join ', ', @stuff
|
---|
351 | );
|
---|
352 |
|
---|
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!
|
---|
357 |
|
---|
358 | All of the above special cases can occasionally cause some
|
---|
359 | problems. See L</BUGS and CAVEATS>.
|
---|
360 |
|
---|
361 | =cut
|
---|
362 |
|
---|
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 |
|
---|
368 | sub ok ($;$$) {
|
---|
369 | croak "ok: plan before you test!" if !$planned;
|
---|
370 |
|
---|
371 | local($\,$,); # guard against -l and other things that screw with
|
---|
372 | # print
|
---|
373 |
|
---|
374 | my ($pkg,$file,$line) = caller($TestLevel);
|
---|
375 | my $repetition = ++$history{"$file:$line"};
|
---|
376 | my $context = ("$file at line $line".
|
---|
377 | ($repetition > 1 ? " fail \#$repetition" : ''));
|
---|
378 |
|
---|
379 | # Are we comparing two values?
|
---|
380 | my $compare = 0;
|
---|
381 |
|
---|
382 | my $ok=0;
|
---|
383 | my $result = _to_value(shift);
|
---|
384 | my ($expected, $isregex, $regex);
|
---|
385 | if (@_ == 0) {
|
---|
386 | $ok = $result;
|
---|
387 | } else {
|
---|
388 | $compare = 1;
|
---|
389 | $expected = _to_value(shift);
|
---|
390 | if (!defined $expected) {
|
---|
391 | $ok = !defined $result;
|
---|
392 | } elsif (!defined $result) {
|
---|
393 | $ok = 0;
|
---|
394 | } elsif (ref($expected) eq 'Regexp') {
|
---|
395 | $ok = $result =~ /$expected/;
|
---|
396 | $regex = $expected;
|
---|
397 | } elsif (($regex) = ($expected =~ m,^ / (.+) / $,sx) or
|
---|
398 | (undef, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) {
|
---|
399 | $ok = $result =~ /$regex/;
|
---|
400 | } else {
|
---|
401 | $ok = $result eq $expected;
|
---|
402 | }
|
---|
403 | }
|
---|
404 | my $todo = $todo{$ntest};
|
---|
405 | if ($todo and $ok) {
|
---|
406 | $context .= ' TODO?!' if $todo;
|
---|
407 | print $TESTOUT "ok $ntest # ($context)\n";
|
---|
408 | } else {
|
---|
409 | # Issuing two seperate prints() causes problems on VMS.
|
---|
410 | if (!$ok) {
|
---|
411 | print $TESTOUT "not ok $ntest\n";
|
---|
412 | }
|
---|
413 | else {
|
---|
414 | print $TESTOUT "ok $ntest\n";
|
---|
415 | }
|
---|
416 |
|
---|
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 |
|
---|
426 | }
|
---|
427 | ++ $ntest;
|
---|
428 | $ok;
|
---|
429 | }
|
---|
430 |
|
---|
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 |
|
---|
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 =
|
---|
636 | $^O =~ m/MSWin/ ? 'Skip if under MSWin' : '';
|
---|
637 |
|
---|
638 | # A test to be skipped if under MSWin (i.e., run except under MSWin)
|
---|
639 | skip($if_MSWin, thing($foo), thing($bar) );
|
---|
640 |
|
---|
641 | Or, going the other way:
|
---|
642 |
|
---|
643 | my $unless_MSWin =
|
---|
644 | $^O =~ m/MSWin/ ? '' : 'Skip unless under MSWin';
|
---|
645 |
|
---|
646 | # A test to be skipped unless under MSWin (i.e., run only under MSWin)
|
---|
647 | skip($unless_MSWin, thing($foo), thing($bar) );
|
---|
648 |
|
---|
649 | The tricky thing to remember is that the first parameter is true if
|
---|
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 |
|
---|
693 | sub skip ($;$$$) {
|
---|
694 | local($\, $,); # guard against -l and other things that screw with
|
---|
695 | # print
|
---|
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;
|
---|
710 | } else {
|
---|
711 | # backwards compatiblity (I think). skip() used to be
|
---|
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
|
---|
718 |
|
---|
719 | local($TestLevel) = $TestLevel+1; #to ignore this stack frame
|
---|
720 | return &ok(@_);
|
---|
721 | }
|
---|
722 | }
|
---|
723 |
|
---|
724 | =back
|
---|
725 |
|
---|
726 | =cut
|
---|
727 |
|
---|
728 | END {
|
---|
729 | $ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL;
|
---|
730 | }
|
---|
731 |
|
---|
732 | 1;
|
---|
733 | __END__
|
---|
734 |
|
---|
735 | =head1 TEST TYPES
|
---|
736 |
|
---|
737 | =over 4
|
---|
738 |
|
---|
739 | =item * NORMAL TESTS
|
---|
740 |
|
---|
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
|
---|
743 | means that something is I<wrong>.
|
---|
744 |
|
---|
745 | =item * SKIPPED TESTS
|
---|
746 |
|
---|
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
|
---|
750 | should evaluate to true (think "yes, please skip") if the required
|
---|
751 | feature is I<not> available. After the first argument, C<skip(...)> works
|
---|
752 | exactly the same way as C<ok(...)> does.
|
---|
753 |
|
---|
754 | =item * TODO TESTS
|
---|
755 |
|
---|
756 | TODO tests are designed for maintaining an B<executable TODO list>.
|
---|
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?
|
---|
760 |
|
---|
761 | Packages should NOT be released with succeeding TODO tests. As soon
|
---|
762 | as a TODO test starts working, it should be promoted to a normal test,
|
---|
763 | and the newly working feature should be documented in the release
|
---|
764 | notes or in the change log.
|
---|
765 |
|
---|
766 | =back
|
---|
767 |
|
---|
768 | =head1 ONFAIL
|
---|
769 |
|
---|
770 | BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } }
|
---|
771 |
|
---|
772 | Although test failures should be enough, extra diagnostics can be
|
---|
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
|
---|
776 | C<result>. (You shouldn't rely on any other fields being present.) If the test
|
---|
777 | had an expected value or a diagnostic (or "note") string, these will also be
|
---|
778 | included.
|
---|
779 |
|
---|
780 | The I<optional> C<onfail> hook might be used simply to print out the
|
---|
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
|
---|
787 | than the code it is testing, yes?)
|
---|
788 |
|
---|
789 |
|
---|
790 | =head1 BUGS and CAVEATS
|
---|
791 |
|
---|
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/' );
|
---|
805 |
|
---|
806 | =item *
|
---|
807 |
|
---|
808 | C<ok(...)>'s use of string C<eq> can sometimes cause odd problems
|
---|
809 | when comparing
|
---|
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 |
|
---|
819 | =item *
|
---|
820 |
|
---|
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)>.
|
---|
830 |
|
---|
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 |
|
---|
889 | =back
|
---|
890 |
|
---|
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 |
|
---|
911 | =head1 NOTE
|
---|
912 |
|
---|
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>.
|
---|
920 |
|
---|
921 | Some earlier versions of this module had docs with some confusing
|
---|
922 | typoes in the description of C<skip(...)>.
|
---|
923 |
|
---|
924 |
|
---|
925 | =head1 SEE ALSO
|
---|
926 |
|
---|
927 | L<Test::Harness>
|
---|
928 |
|
---|
929 | L<Test::Simple>, L<Test::More>, L<Devel::Cover>
|
---|
930 |
|
---|
931 | L<Test::Builder> for building your own testing library.
|
---|
932 |
|
---|
933 | L<Test::Unit> is an interesting XUnit-style testing library.
|
---|
934 |
|
---|
935 | L<Test::Inline> and L<SelfTest> let you embed tests in code.
|
---|
936 |
|
---|
937 |
|
---|
938 | =head1 AUTHOR
|
---|
939 |
|
---|
940 | Copyright (c) 1998-2000 Joshua Nathaniel Pritikin. All rights reserved.
|
---|
941 |
|
---|
942 | Copyright (c) 2001-2002 Michael G. Schwern.
|
---|
943 |
|
---|
944 | Copyright (c) 2002-2004 and counting Sean M. Burke.
|
---|
945 |
|
---|
946 | Current maintainer: Sean M. Burke. E<lt>[email protected]<gt>
|
---|
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
|
---|
950 | under the same terms as Perl itself.
|
---|
951 |
|
---|
952 | =cut
|
---|
953 |
|
---|
954 | # "Your mistake was a hidden intention."
|
---|
955 | # -- /Oblique Strategies/, Brian Eno and Peter Schmidt
|
---|