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