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