extra code in pp_concat, Take 2
[p5sagit/p5-mst-13.2.git] / lib / Test.pm
CommitLineData
809908f7 1
2require 5.004;
75fa620a 3package Test;
ff56af3d 4# Time-stamp: "2004-04-28 21:46:51 ADT"
809908f7 5
6use strict;
7
7b13a3f5 8use Carp;
809908f7 9use 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 12 );
13
711cdd39 14# In case a test is run in a persistent environment.
15sub _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 25require Exporter;
26@ISA=('Exporter');
809908f7 27
28@EXPORT = qw(&plan &ok &skip);
711cdd39 29@EXPORT_OK = qw($ntest $TESTOUT $TESTERR);
7b13a3f5 30
31$|=1;
f2ac83ee 32$TESTOUT = *STDOUT{IO};
711cdd39 33$TESTERR = *STDERR{IO};
7b13a3f5 34
3238f5fe 35# Use of this variable is strongly discouraged. It is set mainly to
36# help test coverage analyzers know which test is running.
7b13a3f5 37$ENV{REGRESSION_TEST} = $0;
38
809908f7 39
40=head1 NAME
41
42Test - 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 55 # Helpful notes. All note-lines must start with a "#".
56 print "# I'm testing MyModule version $MyModule::VERSION\n";
57
809908f7 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 71
72 my @list = (0,0);
75fa620a 73 ok @list, 3, "\@list=".join(',',@list); #extra notes
809908f7 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 78 $foo, $bar # arguments just like for ok(...)
79 );
80 skip(
ff56af3d 81 $^O =~ m/MSWin/ ? 0 : "Skip unless MSWin", # whether to skip
75fa620a 82 $foo, $bar # arguments just like for ok(...)
83 );
809908f7 84
85=head1 DESCRIPTION
86
75fa620a 87This module simplifies the task of writing test files for Perl modules,
88such that their output is in the format that
89L<Test::Harness|Test::Harness> expects to see.
edd5bad5 90
75fa620a 91=head1 QUICK START GUIDE
809908f7 92
75fa620a 93To write a test for your new (and probably not even done) module, create
94a new file called F<t/test.t> (in a new F<t> directory). If you have
95multiple test files, to test the "foo", "bar", and "baz" feature sets,
96then feel free to call your files F<t/foo.t>, F<t/bar.t>, and
97F<t/baz.t>
809908f7 98
99=head2 Functions
100
75fa620a 101This module defines three public functions, C<plan(...)>, C<ok(...)>,
102and C<skip(...)>. By default, all three are exported by
103the C<use Test;> statement.
809908f7 104
105=over 4
106
75fa620a 107=item C<plan(...)>
809908f7 108
109 BEGIN { plan %theplan; }
110
111This should be the first thing you call in your test script. It
112declares your testing plan, how many there will be, if any of them
75fa620a 113should be allowed to fail, and so on.
809908f7 114
115Typical usage is just:
116
117 use Test;
118 BEGIN { plan tests => 23 }
119
75fa620a 120These 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
126The number of tests in your script.
127This means all ok() and skip() calls.
128
129=item C<todo =E<gt> [I<1,5,14>]>
130
131A reference to a list of tests which are allowed to fail.
132See 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 138A subroutine reference to be run at the end of the test script, if
139any of the tests fail. See L</ONFAIL>.
140
141=back
142
143You must call C<plan(...)> once and only once. You should call it
144in a C<BEGIN {...}> block, like so:
145
146 BEGIN { plan tests => 23 }
809908f7 147
148=cut
149
7b13a3f5 150sub 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 153
154 local($\, $,); # guard against -l and other things that screw with
155 # print
156
711cdd39 157 _reset_globals();
158
75fa620a 159 _read_program( (caller)[1] );
160
7b13a3f5 161 my $max=0;
ff56af3d 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 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 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 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 197}
198
75fa620a 199sub _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 210 unshift @{$Program_Lines{$file}}, '';
211 return 1;
212}
809908f7 213
214=begin _private
215
216=item B<_to_value>
217
218 my $value = _to_value($input);
219
75fa620a 220Converts an C<ok> parameter to its value. Typically this just means
ff56af3d 221running it, if it's a code reference. You should run all inputted
809908f7 222values through this.
223
224=cut
225
226sub _to_value {
3238f5fe 227 my ($v) = @_;
ff56af3d 228 return ref $v eq 'CODE' ? $v->() : $v;
3238f5fe 229}
230
ff56af3d 231sub _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 254=end _private
255
75fa620a 256=item C<ok(...)>
809908f7 257
258 ok(1 + 1 == 2);
259 ok($have, $expect);
260 ok($have, $expect, $diagnostics);
261
75fa620a 262This function is the reason for C<Test>'s existence. It's
263the basic function that
264handles printing "C<ok>" or "C<not ok>", along with the
265current test number. (That's what C<Test::Harness> wants to see.)
266
267In its most basic usage, C<ok(...)> simply takes a single scalar
268expression. If its value is true, the test passes; if false,
269the test fails. Examples:
809908f7 270
75fa620a 271 # Examples of ok(scalar)
809908f7 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
279The expression is evaluated in scalar context. So the following will
280work:
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 286A special case is if the expression is a subroutine reference (in either
287C<sub {...}> syntax or C<\&foo> syntax). In
809908f7 288that case, it is executed and its value (true or false) determines if
75fa620a 289the test passes or fails. For example,
809908f7 290
75fa620a 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 297In its two-argument form, C<ok(I<arg1>, I<arg2>)> compares the two
298scalar values to see if they match. They match if both are undefined,
299or if I<arg2> is a regex that matches I<arg1>, or if they compare equal
300with C<eq>.
809908f7 301
75fa620a 302 # Example of ok(scalar, scalar)
303
304 ok( "this", "that" ); # not ok, 'this' ne 'that'
ff56af3d 305 ok( "", undef ); # not ok, "" is defined
306
307The second argument is considered a regex if it is either a regex
308object or a string that looks like a regex. Regex objects are
309constructed with the qr// operator in recent versions of perl. A
310string is considered to look like a regex if its first and last
311characters are "/", or if the first character is "m"
312and its second and last characters are both the
313same non-alphanumeric non-whitespace character. These regexp
314
315Regex 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 322If either (or both!) is a subroutine reference, it is run and used
323as the value for comparing. For example:
324
ff56af3d 325 ok sub {
75fa620a 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 334 ;
335
ff56af3d 336The above test passes two values to C<ok(arg1, arg2)> -- the first
337a coderef, and the second is the number 4. Before C<ok> compares them,
75fa620a 338it calls the coderef, and uses its return value as the real value of
339this parameter. Assuming that C<$bytecount> returns 4, C<ok> ends up
ff56af3d 340testing C<4 eq 4>. Since that's true, this test passes.
809908f7 341
ff56af3d 342Finally, you can append an optional third argument, in
75fa620a 343C<ok(I<arg1>,I<arg2>, I<note>)>, where I<note> is a string value that
344will be printed if the test fails. This should be some useful
345information about the test, pertaining to why it failed, and/or
346a description of the test. For example:
809908f7 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 353Unfortunately, a note cannot be used with the single argument
354style of C<ok()>. That is, if you try C<ok(I<arg1>, I<note>)>, then
355C<Test> will interpret this as C<ok(I<arg1>, I<arg2>)>, and probably
356end up testing C<I<arg1> eq I<arg2>> -- and that's not what you want!
809908f7 357
75fa620a 358All of the above special cases can occasionally cause some
359problems. See L</BUGS and CAVEATS>.
809908f7 360
361=cut
362
75fa620a 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 368sub ok ($;$$) {
369 croak "ok: plan before you test!" if !$planned;
809908f7 370
371 local($\,$,); # guard against -l and other things that screw with
372 # print
373
3238f5fe 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 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 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 401 $ok = $result eq $expected;
402 }
8b3be1d1 403 }
f2ac83ee 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 409 # Issuing two seperate prints() causes problems on VMS.
410 if (!$ok) {
411 print $TESTOUT "not ok $ntest\n";
e5420382 412 }
809908f7 413 else {
414 print $TESTOUT "ok $ntest\n";
e5420382 415 }
75fa620a 416
ff56af3d 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 426 }
427 ++ $ntest;
428 $ok;
429}
430
ff56af3d 431
432sub _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
480sub _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.)
490EOT
491 ;
492 return;
493}
494
495
496
497sub _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
534sub _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 616=item C<skip(I<skip_if_true>, I<args...>)>
617
618This is used for tests that under some conditions can be skipped. It's
619basically 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
628actually "C<ok I<testnum> # I<skip_if_true_value>>".
629
630The arguments after the I<skip_if_true> are what is fed to C<ok(...)> if
631this test isn't skipped.
632
633Example 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 639 skip($if_MSWin, thing($foo), thing($bar) );
640
ff56af3d 641Or, going the other way:
75fa620a 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 647 skip($unless_MSWin, thing($foo), thing($bar) );
648
26bf6773 649The tricky thing to remember is that the first parameter is true if
75fa620a 650you want to I<skip> the test, not I<run> it; and it also doubles as a
651note about why it's being skipped. So in the first codeblock above, read
652the code as "skip if MSWin -- (otherwise) test whether C<thing($foo)> is
653C<thing($bar)>" or for the second case, "skip unless MSWin...".
654
655Also, when your I<skip_if_reason> string is true, it really should (for
656backwards compatibility with older Test.pm versions) start with the
657string "Skip", as shown in the above examples.
658
659Note that in the above cases, C<thing($foo)> and C<thing($bar)>
660I<are> evaluated -- but as long as the C<skip_if_true> is true,
661then we C<skip(...)> just tosses out their value (i.e., not
662bothering to treat them like values to C<ok(...)>. But if
663you need to I<not> eval the arguments when skipping the
664test, use
665this 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
675or even this, which is basically equivalent:
676
677 skip( $unless_MSWin,
678 sub { thing($foo) }, sub { thing($bar) }
679 );
680
681That 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 693sub 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;
7b13a3f5 710 } else {
809908f7 711 # backwards compatiblity (I think). skip() used to be
316cf57b 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 721 }
722}
723
809908f7 724=back
725
726=cut
727
8b3be1d1 728END {
729 $ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL;
730}
731
7b13a3f5 7321;
733__END__
734
3238f5fe 735=head1 TEST TYPES
7b13a3f5 736
737=over 4
738
739=item * NORMAL TESTS
740
75fa620a 741These tests are expected to succeed. Usually, most or all of your tests
742are in this category. If a normal test doesn't succeed, then that
ff56af3d 743means that something is I<wrong>.
7b13a3f5 744
745=item * SKIPPED TESTS
746
75fa620a 747The C<skip(...)> function is for tests that might or might not be
748possible to run, depending
749on the availability of platform-specific features. The first argument
f2ac83ee 750should evaluate to true (think "yes, please skip") if the required
75fa620a 751feature is I<not> available. After the first argument, C<skip(...)> works
752exactly the same way as C<ok(...)> does.
7b13a3f5 753
754=item * TODO TESTS
755
f2ac83ee 756TODO tests are designed for maintaining an B<executable TODO list>.
75fa620a 757These tests are I<expected to fail.> If a TODO test does succeed,
758then the feature in question shouldn't be on the TODO list, now
759should it?
7b13a3f5 760
f2ac83ee 761Packages should NOT be released with succeeding TODO tests. As soon
75fa620a 762as a TODO test starts working, it should be promoted to a normal test,
f2ac83ee 763and the newly working feature should be documented in the release
75fa620a 764notes or in the change log.
7b13a3f5 765
766=back
767
8b3be1d1 768=head1 ONFAIL
769
770 BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } }
771
75fa620a 772Although test failures should be enough, extra diagnostics can be
f2ac83ee 773triggered at the end of a test run. C<onfail> is passed an array ref
774of hash refs that describe each test failure. Each hash will contain
775at least the following fields: C<package>, C<repetition>, and
ff56af3d 776C<result>. (You shouldn't rely on any other fields being present.) If the test
75fa620a 777had an expected value or a diagnostic (or "note") string, these will also be
f2ac83ee 778included.
779
75fa620a 780The I<optional> C<onfail> hook might be used simply to print out the
f2ac83ee 781version of your package and/or how to report problems. It might also
782be used to generate extremely sophisticated diagnostics for a
783particularly bizarre test failure. However it's not a panacea. Core
784dumps or other unrecoverable errors prevent the C<onfail> hook from
785running. (It is run inside an C<END> block.) Besides, C<onfail> is
786probably over-kill in most cases. (Your test code should be simpler
8b3be1d1 787than the code it is testing, yes?)
788
809908f7 789
790=head1 BUGS and CAVEATS
791
75fa620a 792=over
793
794=item *
795
796C<ok(...)>'s special handing of strings which look like they might be
797regexes can also cause unexpected behavior. An innocent:
798
799 ok( $fileglob, '/path/to/some/*stuff/' );
800
801will fail, since Test.pm considers the second argument to be a regex!
802The best bet is to use the one-argument form:
803
804 ok( $fileglob eq '/path/to/some/*stuff/' );
809908f7 805
75fa620a 806=item *
807
808C<ok(...)>'s use of string C<eq> can sometimes cause odd problems
809when comparing
809908f7 810numbers, 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
815Your 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 821As you may have inferred from the above documentation and examples,
822C<ok>'s prototype is C<($;$$)> (and, incidentally, C<skip>'s is
823C<($;$$$)>). This means, for example, that you can do C<ok @foo, @bar>
824to compare the I<size> of the two arrays. But don't be fooled into
825thinking that C<ok @foo, @bar> means a comparison of the contents of two
826arrays -- you're comparing I<just> the number of elements of each. It's
827so easy to make that mistake in reading C<ok @foo, @bar> that you might
828want to be very explicit about it, and instead write C<ok scalar(@foo),
829scalar(@bar)>.
809908f7 830
26bf6773 831=item *
832
833This almost definitely doesn't do what you expect:
834
835 ok $thingy->can('some_method');
836
837Why? Because C<can> returns a coderef to mean "yes it can (and the
838method is this...)", and then C<ok> sees a coderef and thinks you're
839passing a function that you want it to call and consider the truth of
840the result of! I.e., just like:
841
842 ok $thingy->can('some_method')->();
843
844What you probably want instead is this:
845
846 ok $thingy->can('some_method') && 1;
847
848If the C<can> returns false, then that is passed to C<ok>. If it
849returns true, then the larger expression S<< C<<
850$thingy->can('some_method') && 1 >> >> returns 1, which C<ok> sees as
851a simple signal of success, as you would expect.
852
853
854=item *
855
856The syntax for C<skip> is about the only way it can be, but it's still
857quite confusing. Just start with the above examples and you'll
858be okay.
859
860Moreover, users may expect this:
861
862 skip $unless_mswin, foo($bar), baz($quux);
863
864to not evaluate C<foo($bar)> and C<baz($quux)> when the test is being
865skipped. But in reality, they I<are> evaluated, but C<skip> just won't
866bother comparing them if C<$unless_mswin> is true.
867
868You could do this:
869
870 skip $unless_mswin, sub{foo($bar)}, sub{baz($quux)};
871
872But that's not terribly pretty. You may find it simpler or clearer in
873the 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
886But be quite sure that C<ok> is called exactly as many times in the
887first block as C<skip> is called in the second block.
888
75fa620a 889=back
809908f7 890
ff56af3d 891
892=head1 ENVIRONMENT
893
894If C<PERL_TEST_DIFF> environment variable is set, it will be used as a
895command for comparing unexpected multiline results. If you have GNU
896diff installed, you might want to set C<PERL_TEST_DIFF> to C<diff -u>.
897If you don't have a suitable program, you might install the
898C<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
900but the C<Algorithm::Diff> module is available, then it will be used
901to show the differences in multiline results.
902
903=for comment
904If C<PERL_TEST_NO_TRUNC> is set, then the initial "Got 'something' but
905expected 'something_else'" readings for long multiline output values aren't
906truncated at about the 230th column, as they normally could be in some
907cases. Normally you won't need to use this, unless you were carefully
908parsing the output of your test programs.
909
910
711cdd39 911=head1 NOTE
809908f7 912
75fa620a 913A past developer of this module once said that it was no longer being
914actively developed. However, rumors of its demise were greatly
915exaggerated. Feedback and suggestions are quite welcome.
916
917Be aware that the main value of this module is its simplicity. Note
918that there are already more ambitious modules out there, such as
919L<Test::More> and L<Test::Unit>.
809908f7 920
ff56af3d 921Some earlier versions of this module had docs with some confusing
922typoes in the description of C<skip(...)>.
923
809908f7 924
7b13a3f5 925=head1 SEE ALSO
926
75fa620a 927L<Test::Harness>
928
929L<Test::Simple>, L<Test::More>, L<Devel::Cover>
809908f7 930
711cdd39 931L<Test::Builder> for building your own testing library.
932
933L<Test::Unit> is an interesting XUnit-style testing library.
809908f7 934
711cdd39 935L<Test::Inline> and L<SelfTest> let you embed tests in code.
edd5bad5 936
7b13a3f5 937
938=head1 AUTHOR
939
809908f7 940Copyright (c) 1998-2000 Joshua Nathaniel Pritikin. All rights reserved.
809908f7 941
75fa620a 942Copyright (c) 2001-2002 Michael G. Schwern.
943
ff56af3d 944Copyright (c) 2002-2004 and counting Sean M. Burke.
75fa620a 945
946Current maintainer: Sean M. Burke. E<lt>sburke@cpan.orgE<gt>
7b13a3f5 947
948This package is free software and is provided "as is" without express
949or implied warranty. It may be used, redistributed and/or modified
711cdd39 950under the same terms as Perl itself.
7b13a3f5 951
952=cut
75fa620a 953
954# "Your mistake was a hidden intention."
955# -- /Oblique Strategies/, Brian Eno and Peter Schmidt