lib/Test.pm

   1 package Test;
   2
   3 require 5.004;
   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
  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.20';
  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   ok(0); # failure
  55   ok(1); # success
  56
  57   ok(0); # ok, expected failure (see todo list, above)
  58   ok(1); # surprise success!
  59
  60   ok(0,1);             # failure: '0' ne '1'
  61   ok('broke','fixed'); # failure: 'broke' ne 'fixed'
  62   ok('fixed','fixed'); # success: 'fixed' eq 'fixed'
  63   ok('fixed',qr/x/);   # success: 'fixed' =~ qr/x/
  64
  65   ok(sub { 1+1 }, 2);  # success: '2' eq '2'
  66   ok(sub { 1+1 }, 3);  # failure: '2' ne '3'
  67   ok(0, int(rand(2));  # (just kidding :-)
  68
  69   my @list = (0,0);
  70   ok @list, 3, "\@list=".join(',',@list);      #extra diagnostics
  71   ok 'segmentation fault', '/(?i)success/';    #regex match
  72
  73   skip($feature_is_missing, ...);    #do platform specific test
  74
  75 =head1 DESCRIPTION
  76
  77 B<STOP!> If you are writing a new test, we I<highly suggest> you use
  78 the new Test::Simple and Test::More modules instead.
  79
  80 L<Test::Harness|Test::Harness> expects to see particular output when it
  81 executes tests.  This module aims to make writing proper test scripts just
  82 a little bit easier (and less error prone :-).
  83
  84
  85 =head2 Functions
  86
  87 All the following are exported by Test by default.
  88
  89 =over 4
  90
  91 =item B<plan>
  92
  93      BEGIN { plan %theplan; }
  94
  95 This should be the first thing you call in your test script.  It
  96 declares your testing plan, how many there will be, if any of them
  97 should be allowed to fail, etc...
  98
  99 Typical usage is just:
 100
 101      use Test;
 102      BEGIN { plan tests => 23 }
 103
 104 Things you can put in the plan:
 105
 106      tests          The number of tests in your script.
 107                     This means all ok() and skip() calls.
 108      todo           A reference to a list of tests which are allowed
 109                     to fail.  See L</TODO TESTS>.
 110      onfail         A subroutine reference to be run at the end of
 111                     the test script should any of the tests fail.
 112                     See L</ONFAIL>.
 113
 114 You must call plan() once and only once.
 115
 116 =cut
 117
 118 sub plan {
 119     croak "Test::plan(%args): odd number of arguments" if @_ & 1;
 120     croak "Test::plan(): should not be called more than once" if $planned;
 121
 122     local($\, $,);   # guard against -l and other things that screw with
 123                      # print
 124
 125     _reset_globals();
 126
 127     my $max=0;
 128     for (my $x=0; $x < @_; $x+=2) {
 129         my ($k,$v) = @_[$x,$x+1];
 130         if ($k =~ /^test(s)?$/) { $max = $v; }
 131         elsif ($k eq 'todo' or
 132                $k eq 'failok') { for (@$v) { $todo{$_}=1; }; }
 133         elsif ($k eq 'onfail') {
 134             ref $v eq 'CODE' or croak "Test::plan(onfail => $v): must be CODE";
 135             $ONFAIL = $v;
 136         }
 137         else { carp "Test::plan(): skipping unrecognized directive '$k'" }
 138     }
 139     my @todo = sort { $a <=> $b } keys %todo;
 140     if (@todo) {
 141         print $TESTOUT "1..$max todo ".join(' ', @todo).";\n";
 142     } else {
 143         print $TESTOUT "1..$max\n";
 144     }
 145     ++$planned;
 146
 147     # Never used.
 148     return undef;
 149 }
 150
 151
 152 =begin _private
 153
 154 =item B<_to_value>
 155
 156   my $value = _to_value($input);
 157
 158 Converts an ok parameter to its value.  Typically this just means
 159 running it if its a code reference.  You should run all inputed
 160 values through this.
 161
 162 =cut
 163
 164 sub _to_value {
 165     my ($v) = @_;
 166     return (ref $v or '') eq 'CODE' ? $v->() : $v;
 167 }
 168
 169 =end _private
 170
 171 =item B<ok>
 172
 173   ok(1 + 1 == 2);
 174   ok($have, $expect);
 175   ok($have, $expect, $diagnostics);
 176
 177 This is the reason for Test's existance.  Its the basic function that
 178 handles printing "ok" or "not ok" along with the current test number.
 179
 180 In its most basic usage, it simply takes an expression.  If its true,
 181 the test passes, if false, the test fails.  Simp.
 182
 183     ok( 1 + 1 == 2 );           # ok if 1 + 1 == 2
 184     ok( $foo =~ /bar/ );        # ok if $foo contains 'bar'
 185     ok( baz($x + $y) eq 'Armondo' );    # ok if baz($x + $y) returns
 186                                         # 'Armondo'
 187     ok( @a == @b );             # ok if @a and @b are the same length
 188
 189 The expression is evaluated in scalar context.  So the following will
 190 work:
 191
 192     ok( @stuff );                       # ok if @stuff has any elements
 193     ok( !grep !defined $_, @stuff );    # ok if everything in @stuff is
 194                                         # defined.
 195
 196 A special case is if the expression is a subroutine reference.  In
 197 that case, it is executed and its value (true or false) determines if
 198 the test passes or fails.
 199
 200 In its two argument form it compares the two values to see if they
 201 equal (with C<eq>).
 202
 203     ok( "this", "that" );               # not ok, 'this' ne 'that'
 204
 205 If either is a subroutine reference, that is run and used as a
 206 comparison.
 207
 208 Should $expect either be a regex reference (ie. qr//) or a string that
 209 looks like a regex (ie. '/foo/') ok() will perform a pattern match
 210 against it rather than using eq.
 211
 212     ok( 'JaffO', '/Jaff/' );    # ok, 'JaffO' =~ /Jaff/
 213     ok( 'JaffO', qr/Jaff/ );    # ok, 'JaffO' =~ qr/Jaff/;
 214     ok( 'JaffO', '/(?i)jaff/ ); # ok, 'JaffO' =~ /jaff/i;
 215
 216 Finally, an optional set of $diagnostics will be printed should the
 217 test fail.  This should usually be some useful information about the
 218 test pertaining to why it failed or perhaps a description of the test.
 219 Or both.
 220
 221     ok( grep($_ eq 'something unique', @stuff), 1,
 222         "Something that should be unique isn't!\n".
 223         '@stuff = '.join ', ', @stuff
 224       );
 225
 226 Unfortunately, a diagnostic cannot be used with the single argument
 227 style of ok().
 228
 229 All these special cases can cause some problems.  See L</BUGS and CAVEATS>.
 230
 231 =cut
 232
 233 sub ok ($;$$) {
 234     croak "ok: plan before you test!" if !$planned;
 235
 236     local($\,$,);   # guard against -l and other things that screw with
 237                     # print
 238
 239     my ($pkg,$file,$line) = caller($TestLevel);
 240     my $repetition = ++$history{"$file:$line"};
 241     my $context = ("$file at line $line".
 242                    ($repetition > 1 ? " fail \#$repetition" : ''));
 243     my $ok=0;
 244     my $result = _to_value(shift);
 245     my ($expected,$diag,$isregex,$regex);
 246     if (@_ == 0) {
 247         $ok = $result;
 248     } else {
 249         $expected = _to_value(shift);
 250         if (!defined $expected) {
 251             $ok = !defined $result;
 252         } elsif (!defined $result) {
 253             $ok = 0;
 254         } elsif ((ref($expected)||'') eq 'Regexp') {
 255             $ok = $result =~ /$expected/;
 256             $regex = $expected;
 257         } elsif (($regex) = ($expected =~ m,^ / (.+) / $,sx) or
 258             (undef, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) {
 259             $ok = $result =~ /$regex/;
 260         } else {
 261             $ok = $result eq $expected;
 262         }
 263     }
 264     my $todo = $todo{$ntest};
 265     if ($todo and $ok) {
 266         $context .= ' TODO?!' if $todo;
 267         print $TESTOUT "ok $ntest # ($context)\n";
 268     } else {
 269         # Issuing two seperate prints() causes problems on VMS.
 270         if (!$ok) {
 271             print $TESTOUT "not ok $ntest\n";
 272         }
 273         else {
 274             print $TESTOUT "ok $ntest\n";
 275         }
 276
 277         if (!$ok) {
 278             my $detail = { 'repetition' => $repetition, 'package' => $pkg,
 279                            'result' => $result, 'todo' => $todo };
 280             $$detail{expected} = $expected if defined $expected;
 281
 282             # Get the user's diagnostic, protecting against multi-line
 283             # diagnostics.
 284             $diag = $$detail{diagnostic} = _to_value(shift) if @_;
 285             $diag =~ s/\n/\n#/g if defined $diag;
 286
 287             $context .= ' *TODO*' if $todo;
 288             if (!defined $expected) {
 289                 if (!$diag) {
 290                     print $TESTERR "# Failed test $ntest in $context\n";
 291                 } else {
 292                     print $TESTERR "# Failed test $ntest in $context: $diag\n";
 293                 }
 294             } else {
 295                 my $prefix = "Test $ntest";
 296                 print $TESTERR "# $prefix got: ".
 297                     (defined $result? "'$result'":'<UNDEF>')." ($context)\n";
 298                 $prefix = ' ' x (length($prefix) - 5);
 299                 if (defined $regex) {
 300                     $expected = 'qr{'.$regex.'}';
 301                 }
 302                 else {
 303                     $expected = "'$expected'";
 304                 }
 305                 if (!$diag) {
 306                     print $TESTERR "# $prefix Expected: $expected\n";
 307                 } else {
 308                     print $TESTERR "# $prefix Expected: $expected ($diag)\n";
 309                 }
 310             }
 311             push @FAILDETAIL, $detail;
 312         }
 313     }
 314     ++ $ntest;
 315     $ok;
 316 }
 317
 318 sub skip ($;$$$) {
 319     local($\, $,);   # guard against -l and other things that screw with
 320                      # print
 321
 322     my $whyskip = _to_value(shift);
 323     if (!@_ or $whyskip) {
 324         $whyskip = '' if $whyskip =~ m/^\d+$/;
 325         $whyskip =~ s/^[Ss]kip(?:\s+|$)//;  # backwards compatibility, old
 326                                             # versions required the reason
 327                                             # to start with 'skip'
 328         # We print in one shot for VMSy reasons.
 329         my $ok = "ok $ntest # skip";
 330         $ok .= " $whyskip" if length $whyskip;
 331         $ok .= "\n";
 332         print $TESTOUT $ok;
 333         ++ $ntest;
 334         return 1;
 335     } else {
 336         # backwards compatiblity (I think).  skip() used to be
 337         # called like ok(), which is weird.  I haven't decided what to do with
 338         # this yet.
 339 #        warn <<WARN if $^W;
 340 #This looks like a skip() using the very old interface.  Please upgrade to
 341 #the documented interface as this has been deprecated.
 342 #WARN
 343
 344         local($TestLevel) = $TestLevel+1;  #ignore this stack frame
 345         return &ok(@_);
 346     }
 347 }
 348
 349 =back
 350
 351 =cut
 352
 353 END {
 354     $ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL;
 355 }
 356
 357 1;
 358 __END__
 359
 360 =head1 TEST TYPES
 361
 362 =over 4
 363
 364 =item * NORMAL TESTS
 365
 366 These tests are expected to succeed.  If they don't something's
 367 screwed up!
 368
 369 =item * SKIPPED TESTS
 370
 371 Skip is for tests that might or might not be possible to run depending
 372 on the availability of platform specific features.  The first argument
 373 should evaluate to true (think "yes, please skip") if the required
 374 feature is not available.  After the first argument, skip works
 375 exactly the same way as do normal tests.
 376
 377 =item * TODO TESTS
 378
 379 TODO tests are designed for maintaining an B<executable TODO list>.
 380 These tests are expected NOT to succeed.  If a TODO test does succeed,
 381 the feature in question should not be on the TODO list, now should it?
 382
 383 Packages should NOT be released with succeeding TODO tests.  As soon
 384 as a TODO test starts working, it should be promoted to a normal test
 385 and the newly working feature should be documented in the release
 386 notes or change log.
 387
 388 =back
 389
 390 =head1 ONFAIL
 391
 392   BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } }
 393
 394 While test failures should be enough, extra diagnostics can be
 395 triggered at the end of a test run.  C<onfail> is passed an array ref
 396 of hash refs that describe each test failure.  Each hash will contain
 397 at least the following fields: C<package>, C<repetition>, and
 398 C<result>.  (The file, line, and test number are not included because
 399 their correspondence to a particular test is tenuous.)  If the test
 400 had an expected value or a diagnostic string, these will also be
 401 included.
 402
 403 The B<optional> C<onfail> hook might be used simply to print out the
 404 version of your package and/or how to report problems.  It might also
 405 be used to generate extremely sophisticated diagnostics for a
 406 particularly bizarre test failure.  However it's not a panacea.  Core
 407 dumps or other unrecoverable errors prevent the C<onfail> hook from
 408 running.  (It is run inside an C<END> block.)  Besides, C<onfail> is
 409 probably over-kill in most cases.  (Your test code should be simpler
 410 than the code it is testing, yes?)
 411
 412
 413 =head1 BUGS and CAVEATS
 414
 415 ok()'s special handling of subroutine references is an unfortunate
 416 "feature" that can't be removed due to compatibility.
 417
 418 ok()'s use of string eq can sometimes cause odd problems when comparing
 419 numbers, especially if you're casting a string to a number:
 420
 421     $foo = "1.0";
 422     ok( $foo, 1 );      # not ok, "1.0" ne 1
 423
 424 Your best bet is to use the single argument form:
 425
 426     ok( $foo == 1 );    # ok "1.0" == 1
 427
 428 ok()'s special handing of strings which look like they might be
 429 regexes can also cause unexpected behavior.  An innocent:
 430
 431     ok( $fileglob, '/path/to/some/*stuff/' );
 432
 433 will fail since Test.pm considers the second argument to a regex.
 434 Again, best bet is to use the single argument form:
 435
 436     ok( $fileglob eq '/path/to/some/*stuff/' );
 437
 438
 439 =head1 NOTE
 440
 441 This module is no longer actively being developed, only bug fixes and
 442 small tweaks (I'll still accept patches).  If you desire additional
 443 functionality, consider L<Test::More> or L<Test::Unit>.
 444
 445
 446 =head1 SEE ALSO
 447
 448 L<Test::Simple>, L<Test::More>, L<Test::Harness>, L<Devel::Cover>
 449
 450 L<Test::Builder> for building your own testing library.
 451
 452 L<Test::Unit> is an interesting XUnit-style testing library.
 453
 454 L<Test::Inline> and L<SelfTest> let you embed tests in code.
 455
 456
 457 =head1 AUTHOR
 458
 459 Copyright (c) 1998-2000 Joshua Nathaniel Pritikin.  All rights reserved.
 460 Copyright (c) 2001-2002 Michael G Schwern.
 461
 462 Current maintainer, Michael G Schwern <schwern@pobox.com>
 463
 464 This package is free software and is provided "as is" without express
 465 or implied warranty.  It may be used, redistributed and/or modified
 466 under the same terms as Perl itself.
 467
 468 =cut