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