lib/Test.pm

   1 use strict;
   2 package Test;
   3 use Test::Harness 1.1601 ();
   4 use Carp;
   5 our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $ntest, $TestLevel); #public-ish
   6 our($TESTOUT, $ONFAIL, %todo, %history, $planned, @FAILDETAIL); #private-ish
   7 $VERSION = '1.15';
   8 require Exporter;
   9 @ISA=('Exporter');
  10 @EXPORT=qw(&plan &ok &skip);
  11 @EXPORT_OK=qw($ntest $TESTOUT);
  12
  13 $TestLevel = 0;         # how many extra stack frames to skip
  14 $|=1;
  15 #$^W=1;  ?
  16 $ntest=1;
  17 $TESTOUT = *STDOUT{IO};
  18
  19 # Use of this variable is strongly discouraged.  It is set mainly to
  20 # help test coverage analyzers know which test is running.
  21 $ENV{REGRESSION_TEST} = $0;
  22
  23 sub plan {
  24     croak "Test::plan(%args): odd number of arguments" if @_ & 1;
  25     croak "Test::plan(): should not be called more than once" if $planned;
  26     my $max=0;
  27     for (my $x=0; $x < @_; $x+=2) {
  28         my ($k,$v) = @_[$x,$x+1];
  29         if ($k =~ /^test(s)?$/) { $max = $v; }
  30         elsif ($k eq 'todo' or
  31                $k eq 'failok') { for (@$v) { $todo{$_}=1; }; }
  32         elsif ($k eq 'onfail') {
  33             ref $v eq 'CODE' or croak "Test::plan(onfail => $v): must be CODE";
  34             $ONFAIL = $v;
  35         }
  36         else { carp "Test::plan(): skipping unrecognized directive '$k'" }
  37     }
  38     my @todo = sort { $a <=> $b } keys %todo;
  39     if (@todo) {
  40         print $TESTOUT "1..$max todo ".join(' ', @todo).";\n";
  41     } else {
  42         print $TESTOUT "1..$max\n";
  43     }
  44     ++$planned;
  45 }
  46
  47 sub to_value {
  48     my ($v) = @_;
  49     (ref $v or '') eq 'CODE' ? $v->() : $v;
  50 }
  51
  52 sub ok ($;$$) {
  53     croak "ok: plan before you test!" if !$planned;
  54     my ($pkg,$file,$line) = caller($TestLevel);
  55     my $repetition = ++$history{"$file:$line"};
  56     my $context = ("$file at line $line".
  57                    ($repetition > 1 ? " fail \#$repetition" : ''));
  58     my $ok=0;
  59     my $result = to_value(shift);
  60     my ($expected,$diag);
  61     if (@_ == 0) {
  62         $ok = $result;
  63     } else {
  64         $expected = to_value(shift);
  65         my ($regex,$ignore);
  66         if (!defined $expected) {
  67             $ok = !defined $result;
  68         } elsif (!defined $result) {
  69             $ok = 0;
  70         } elsif ((ref($expected)||'') eq 'Regexp') {
  71             $ok = $result =~ /$expected/;
  72         } elsif (($regex) = ($expected =~ m,^ / (.+) / $,sx) or
  73             ($ignore, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) {
  74             $ok = $result =~ /$regex/;
  75         } else {
  76             $ok = $result eq $expected;
  77         }
  78     }
  79     my $todo = $todo{$ntest};
  80     if ($todo and $ok) {
  81         $context .= ' TODO?!' if $todo;
  82         print $TESTOUT "ok $ntest # ($context)\n";
  83     } else {
  84         # Issuing two separate print()s causes severe trouble with
  85         # Test::Harness on VMS.  The "not "'s for failed tests occur
  86         # on a separate line and would not get counted as failures.
  87         #print $TESTOUT "not " if !$ok;
  88         #print $TESTOUT "ok $ntest\n";
  89         # Replace with a single print() as a workaround:
  90         my $okline = '';
  91         $okline = "not " if !$ok;
  92         $okline .= "ok $ntest\n";
  93         print $TESTOUT $okline;
  94
  95         if (!$ok) {
  96             my $detail = { 'repetition' => $repetition, 'package' => $pkg,
  97                            'result' => $result, 'todo' => $todo };
  98             $$detail{expected} = $expected if defined $expected;
  99             $diag = $$detail{diagnostic} = to_value(shift) if @_;
 100             $context .= ' *TODO*' if $todo;
 101             if (!defined $expected) {
 102                 if (!$diag) {
 103                     print $TESTOUT "# Failed test $ntest in $context\n";
 104                 } else {
 105                     print $TESTOUT "# Failed test $ntest in $context: $diag\n";
 106                 }
 107             } else {
 108                 my $prefix = "Test $ntest";
 109                 print $TESTOUT "# $prefix got: ".
 110                     (defined $result? "'$result'":'<UNDEF>')." ($context)\n";
 111                 $prefix = ' ' x (length($prefix) - 5);
 112                 if ((ref($expected)||'') eq 'Regexp') {
 113                     $expected = 'qr/'.$expected.'/'
 114                 } else {
 115                     $expected = "'$expected'";
 116                 }
 117                 if (!$diag) {
 118                     print $TESTOUT "# $prefix Expected: $expected\n";
 119                 } else {
 120                     print $TESTOUT "# $prefix Expected: $expected ($diag)\n";
 121                 }
 122             }
 123             push @FAILDETAIL, $detail;
 124         }
 125     }
 126     ++ $ntest;
 127     $ok;
 128 }
 129
 130 sub skip ($$;$$) {
 131     my $whyskip = to_value(shift);
 132     if ($whyskip) {
 133         $whyskip = 'skip' if $whyskip =~ m/^\d+$/;
 134         print $TESTOUT "ok $ntest # $whyskip\n";
 135         ++ $ntest;
 136         1;
 137     } else {
 138         local($TestLevel) = $TestLevel+1;  #ignore this stack frame
 139         &ok;
 140     }
 141 }
 142
 143 END {
 144     $ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL;
 145 }
 146
 147 1;
 148 __END__
 149
 150 =head1 NAME
 151
 152   Test - provides a simple framework for writing test scripts
 153
 154 =head1 SYNOPSIS
 155
 156   use strict;
 157   use Test;
 158
 159   # use a BEGIN block so we print our plan before MyModule is loaded
 160   BEGIN { plan tests => 14, todo => [3,4] }
 161
 162   # load your module...
 163   use MyModule;
 164
 165   ok(0); # failure
 166   ok(1); # success
 167
 168   ok(0); # ok, expected failure (see todo list, above)
 169   ok(1); # surprise success!
 170
 171   ok(0,1);             # failure: '0' ne '1'
 172   ok('broke','fixed'); # failure: 'broke' ne 'fixed'
 173   ok('fixed','fixed'); # success: 'fixed' eq 'fixed'
 174   ok('fixed',qr/x/);   # success: 'fixed' =~ qr/x/
 175
 176   ok(sub { 1+1 }, 2);  # success: '2' eq '2'
 177   ok(sub { 1+1 }, 3);  # failure: '2' ne '3'
 178   ok(0, int(rand(2));  # (just kidding :-)
 179
 180   my @list = (0,0);
 181   ok @list, 3, "\@list=".join(',',@list);      #extra diagnostics
 182   ok 'segmentation fault', '/(?i)success/';    #regex match
 183
 184   skip($feature_is_missing, ...);    #do platform specific test
 185
 186 =head1 DESCRIPTION
 187
 188 L<Test::Harness|Test::Harness> expects to see particular output when it
 189 executes tests.  This module aims to make writing proper test scripts just
 190 a little bit easier (and less error prone :-).
 191
 192 =head1 TEST TYPES
 193
 194 =over 4
 195
 196 =item * NORMAL TESTS
 197
 198 These tests are expected to succeed.  If they don't something's
 199 screwed up!
 200
 201 =item * SKIPPED TESTS
 202
 203 Skip is for tests that might or might not be possible to run depending
 204 on the availability of platform specific features.  The first argument
 205 should evaluate to true (think "yes, please skip") if the required
 206 feature is not available.  After the first argument, skip works
 207 exactly the same way as do normal tests.
 208
 209 =item * TODO TESTS
 210
 211 TODO tests are designed for maintaining an B<executable TODO list>.
 212 These tests are expected NOT to succeed.  If a TODO test does succeed,
 213 the feature in question should not be on the TODO list, now should it?
 214
 215 Packages should NOT be released with succeeding TODO tests.  As soon
 216 as a TODO test starts working, it should be promoted to a normal test
 217 and the newly working feature should be documented in the release
 218 notes or change log.
 219
 220 =back
 221
 222 =head1 RETURN VALUE
 223
 224 Both C<ok> and C<skip> return true if their test succeeds and false
 225 otherwise in a scalar context.
 226
 227 =head1 ONFAIL
 228
 229   BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } }
 230
 231 While test failures should be enough, extra diagnostics can be
 232 triggered at the end of a test run.  C<onfail> is passed an array ref
 233 of hash refs that describe each test failure.  Each hash will contain
 234 at least the following fields: C<package>, C<repetition>, and
 235 C<result>.  (The file, line, and test number are not included because
 236 their correspondence to a particular test is tenuous.)  If the test
 237 had an expected value or a diagnostic string, these will also be
 238 included.
 239
 240 The B<optional> C<onfail> hook might be used simply to print out the
 241 version of your package and/or how to report problems.  It might also
 242 be used to generate extremely sophisticated diagnostics for a
 243 particularly bizarre test failure.  However it's not a panacea.  Core
 244 dumps or other unrecoverable errors prevent the C<onfail> hook from
 245 running.  (It is run inside an C<END> block.)  Besides, C<onfail> is
 246 probably over-kill in most cases.  (Your test code should be simpler
 247 than the code it is testing, yes?)
 248
 249 =head1 SEE ALSO
 250
 251 L<Test::Harness> and, perhaps, test coverage analysis tools.
 252
 253 =head1 AUTHOR
 254
 255 Copyright (c) 1998-1999 Joshua Nathaniel Pritikin.  All rights reserved.
 256
 257 This package is free software and is provided "as is" without express
 258 or implied warranty.  It may be used, redistributed and/or modified
 259 under the terms of the Perl Artistic License (see
 260 http://www.perl.com/perl/misc/Artistic.html)
 261
 262 =cut