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