1 2require 5.004; 3package Test; 4# Time-stamp: "2004-04-28 21:46:51 ADT" 5 6use strict; 7 8use Carp; 9use 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. 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 24$VERSION = '1.25'; 25require 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 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 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 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. 90 91=head1 QUICK START GUIDE 92 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> 98 99=head2 Functions 100 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. 104 105=over 4 106 107=item C<plan(...)> 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 113should be allowed to fail, and so on. 114 115Typical usage is just: 116 117 use Test; 118 BEGIN { plan tests => 23 } 119 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 { ... }> 135 136=item C<onfail =E<gt> \&some_sub> 137 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 } 147 148=cut 149 150sub 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 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); 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 220Converts an C<ok> parameter to its value. Typically this just means 221running it, if it's a code reference. You should run all inputted 222values through this. 223 224=cut 225 226sub _to_value { 227 my ($v) = @_; 228 return ref $v eq 'CODE' ? $v->() : $v; 229} 230 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 254=end _private 255 256=item C<ok(...)> 257 258 ok(1 + 1 == 2); 259 ok($have, $expect); 260 ok($have, $expect, $diagnostics); 261 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: 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 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 286A special case is if the expression is a subroutine reference (in either 287C<sub {...}> syntax or C<\&foo> syntax). In 288that case, it is executed and its value (true or false) determines if 289the 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 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>. 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 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; 321 322If either (or both!) is a subroutine reference, it is run and used 323as 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 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, 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 340testing C<4 eq 4>. Since that's true, this test passes. 341 342Finally, you can append an optional third argument, in 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: 347 348 ok( grep($_ eq 'something unique', @stuff), 1, 349 "Something that should be unique isn't!\n". 350 '@stuff = '.join ', ', @stuff 351 ); 352 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! 357 358All of the above special cases can occasionally cause some 359problems. 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 368sub 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 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 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 = 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 641Or, 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 649The tricky thing to remember is that the first parameter is true if 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 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; 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 728END { 729 $ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL; 730} 731 7321; 733__END__ 734 735=head1 TEST TYPES 736 737=over 4 738 739=item * NORMAL TESTS 740 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 743means that something is I<wrong>. 744 745=item * SKIPPED TESTS 746 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 750should evaluate to true (think "yes, please skip") if the required 751feature is I<not> available. After the first argument, C<skip(...)> works 752exactly the same way as C<ok(...)> does. 753 754=item * TODO TESTS 755 756TODO tests are designed for maintaining an B<executable TODO list>. 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? 760 761Packages should NOT be released with succeeding TODO tests. As soon 762as a TODO test starts working, it should be promoted to a normal test, 763and the newly working feature should be documented in the release 764notes or in the change log. 765 766=back 767 768=head1 ONFAIL 769 770 BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } } 771 772Although test failures should be enough, extra diagnostics can be 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 776C<result>. (You shouldn't rely on any other fields being present.) If the test 777had an expected value or a diagnostic (or "note") string, these will also be 778included. 779 780The I<optional> C<onfail> hook might be used simply to print out the 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 787than the code it is testing, yes?) 788 789 790=head1 BUGS and CAVEATS 791 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/' ); 805 806=item * 807 808C<ok(...)>'s use of string C<eq> can sometimes cause odd problems 809when comparing 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 819=item * 820 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)>. 830 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 889=back 890 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 911=head1 NOTE 912 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>. 920 921Some earlier versions of this module had docs with some confusing 922typoes in the description of C<skip(...)>. 923 924 925=head1 SEE ALSO 926 927L<Test::Harness> 928 929L<Test::Simple>, L<Test::More>, L<Devel::Cover> 930 931L<Test::Builder> for building your own testing library. 932 933L<Test::Unit> is an interesting XUnit-style testing library. 934 935L<Test::Inline> and L<SelfTest> let you embed tests in code. 936 937 938=head1 AUTHOR 939 940Copyright (c) 1998-2000 Joshua Nathaniel Pritikin. All rights reserved. 941 942Copyright (c) 2001-2002 Michael G. Schwern. 943 944Copyright (c) 2002-2004 and counting Sean M. Burke. 945 946Current maintainer: Sean M. Burke. E<lt>sburke@cpan.orgE<gt> 947 948This package is free software and is provided "as is" without express 949or implied warranty. It may be used, redistributed and/or modified 950under 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 956