[Summary view] [Print] [Text view]

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