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