lib/Test.pm

   1 use strict;
   2 package Test;
   3 use Test::Harness 1.1601 ();
   4 use Carp;
   5 use vars (qw($VERSION @ISA @EXPORT @EXPORT_OK $ntest $TestLevel), #public-ish
   6           qw($TESTOUT $ONFAIL %todo %history $planned @FAILDETAIL)); #private-ish
   7 $VERSION = '1.13';
   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         print $TESTOUT "not " if !$ok;
  85         print $TESTOUT "ok $ntest\n";
  86
  87         if (!$ok) {
  88             my $detail = { 'repetition' => $repetition, 'package' => $pkg,
  89                            'result' => $result, 'todo' => $todo };
  90             $$detail{expected} = $expected if defined $expected;
  91             $diag = $$detail{diagnostic} = to_value(shift) if @_;
  92             $context .= ' *TODO*' if $todo;
  93             if (!defined $expected) {
  94                 if (!$diag) {
  95                     print $TESTOUT "# Failed test $ntest in $context\n";
  96                 } else {
  97                     print $TESTOUT "# Failed test $ntest in $context: $diag\n";
  98                 }
  99             } else {
 100                 my $prefix = "Test $ntest";
 101                 print $TESTOUT "# $prefix got: ".
 102                     (defined $result? "'$result'":'<UNDEF>')." ($context)\n";
 103                 $prefix = ' ' x (length($prefix) - 5);
 104                 if ((ref($expected)||'') eq 'Regexp') {
 105                     $expected = 'qr/'.$expected.'/'
 106                 } else {
 107                     $expected = "'$expected'";
 108                 }
 109                 if (!$diag) {
 110                     print $TESTOUT "# $prefix Expected: $expected\n";
 111                 } else {
 112                     print $TESTOUT "# $prefix Expected: $expected ($diag)\n";
 113                 }
 114             }
 115             push @FAILDETAIL, $detail;
 116         }
 117     }
 118     ++ $ntest;
 119     $ok;
 120 }
 121
 122 sub skip ($$;$$) {
 123     my $whyskip = to_value(shift);
 124     if ($whyskip) {
 125         $whyskip = 'skip' if $whyskip =~ m/^\d+$/;
 126         print $TESTOUT "ok $ntest # $whyskip\n";
 127         ++ $ntest;
 128         1;
 129     } else {
 130         local($TestLevel) = $TestLevel+1;  #ignore this stack frame
 131         &ok;
 132     }
 133 }
 134
 135 END {
 136     $ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL;
 137 }
 138
 139 1;
 140 __END__
 141
 142 =head1 NAME
 143
 144   Test - provides a simple framework for writing test scripts
 145
 146 =head1 SYNOPSIS
 147
 148   use strict;
 149   use Test;
 150
 151   # use a BEGIN block so we print our plan before MyModule is loaded
 152   BEGIN { plan tests => 14, todo => [3,4] }
 153
 154   # load your module...
 155   use MyModule;
 156
 157   ok(0); # failure
 158   ok(1); # success
 159
 160   ok(0); # ok, expected failure (see todo list, above)
 161   ok(1); # surprise success!
 162
 163   ok(0,1);             # failure: '0' ne '1'
 164   ok('broke','fixed'); # failure: 'broke' ne 'fixed'
 165   ok('fixed','fixed'); # success: 'fixed' eq 'fixed'
 166   ok('fixed',qr/x/);   # success: 'fixed' =~ qr/x/
 167
 168   ok(sub { 1+1 }, 2);  # success: '2' eq '2'
 169   ok(sub { 1+1 }, 3);  # failure: '2' ne '3'
 170   ok(0, int(rand(2));  # (just kidding :-)
 171
 172   my @list = (0,0);
 173   ok @list, 3, "\@list=".join(',',@list);      #extra diagnostics
 174   ok 'segmentation fault', '/(?i)success/';    #regex match
 175
 176   skip($feature_is_missing, ...);    #do platform specific test
 177
 178 =head1 DESCRIPTION
 179
 180 L<Test::Harness> expects to see particular output when it executes
 181 tests.  This module aims to make writing proper test scripts just a
 182 little bit easier (and less error prone :-).
 183
 184 =head1 TEST TYPES
 185
 186 =over 4
 187
 188 =item * NORMAL TESTS
 189
 190 These tests are expected to succeed.  If they don't something's
 191 screwed up!
 192
 193 =item * SKIPPED TESTS
 194
 195 Skip is for tests that might or might not be possible to run depending
 196 on the availability of platform specific features.  The first argument
 197 should evaluate to true (think "yes, please skip") if the required
 198 feature is not available.  After the first argument, skip works
 199 exactly the same way as do normal tests.
 200
 201 =item * TODO TESTS
 202
 203 TODO tests are designed for maintaining an B<executable TODO list>.
 204 These tests are expected NOT to succeed.  If a TODO test does succeed,
 205 the feature in question should not be on the TODO list, now should it?
 206
 207 Packages should NOT be released with succeeding TODO tests.  As soon
 208 as a TODO test starts working, it should be promoted to a normal test
 209 and the newly working feature should be documented in the release
 210 notes or change log.
 211
 212 =back
 213
 214 =head1 RETURN VALUE
 215
 216 Both C<ok> and C<skip> return true if their test succeeds and false
 217 otherwise in a scalar context.
 218
 219 =head1 ONFAIL
 220
 221   BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } }
 222
 223 While test failures should be enough, extra diagnostics can be
 224 triggered at the end of a test run.  C<onfail> is passed an array ref
 225 of hash refs that describe each test failure.  Each hash will contain
 226 at least the following fields: C<package>, C<repetition>, and
 227 C<result>.  (The file, line, and test number are not included because
 228 their correspondence to a particular test is tenuous.)  If the test
 229 had an expected value or a diagnostic string, these will also be
 230 included.
 231
 232 The B<optional> C<onfail> hook might be used simply to print out the
 233 version of your package and/or how to report problems.  It might also
 234 be used to generate extremely sophisticated diagnostics for a
 235 particularly bizarre test failure.  However it's not a panacea.  Core
 236 dumps or other unrecoverable errors prevent the C<onfail> hook from
 237 running.  (It is run inside an C<END> block.)  Besides, C<onfail> is
 238 probably over-kill in most cases.  (Your test code should be simpler
 239 than the code it is testing, yes?)
 240
 241 =head1 SEE ALSO
 242
 243 L<Test::Harness> and, perhaps, test coverage analysis tools.
 244
 245 =head1 AUTHOR
 246
 247 Copyright (c) 1998-1999 Joshua Nathaniel Pritikin.  All rights reserved.
 248
 249 This package is free software and is provided "as is" without express
 250 or implied warranty.  It may be used, redistributed and/or modified
 251 under the terms of the Perl Artistic License (see
 252 http://www.perl.com/perl/misc/Artistic.html)
 253
 254 =cut