dist/Test/lib/Test.pm

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