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