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 %todo %history $TestLevel);
   6 $VERSION = '0.08';
   7 require Exporter;
   8 @ISA=('Exporter');
   9 @EXPORT= qw(&plan &ok &skip $ntest);
  10
  11 $TestLevel = 0;         # how many extra stack frames to skip
  12 $|=1;
  13 #$^W=1;  ?
  14 $ntest=1;
  15
  16 # Use of this variable is strongly discouraged.  It is set mainly to
  17 # help test coverage analyzers know which test is running.
  18 $ENV{REGRESSION_TEST} = $0;
  19
  20 sub plan {
  21     croak "Test::plan(%args): odd number of arguments" if @_ & 1;
  22     my $max=0;
  23     for (my $x=0; $x < @_; $x+=2) {
  24         my ($k,$v) = @_[$x,$x+1];
  25         if ($k =~ /^test(s)?$/) { $max = $v; }
  26         elsif ($k eq 'todo' or
  27                $k eq 'failok') { for (@$v) { $todo{$_}=1; }; }
  28         else { carp "Test::plan(): skipping unrecognized directive '$k'" }
  29     }
  30     my @todo = sort { $a <=> $b } keys %todo;
  31     if (@todo) {
  32         print "1..$max todo ".join(' ', @todo).";\n";
  33     } else {
  34         print "1..$max\n";
  35     }
  36 }
  37
  38 sub to_value {
  39     my ($v) = @_;
  40     (ref $v or '') eq 'CODE' ? $v->() : $v;
  41 }
  42
  43 # prototypes are not used for maximum flexibility
  44
  45 # STDERR is NOT used for diagnostic output that should be fixed before
  46 # the module is released.
  47
  48 sub ok {
  49     my ($pkg,$file,$line) = caller($TestLevel);
  50     my $repetition = ++$history{"$file:$line"};
  51     my $context = ("$file at line $line".
  52                    ($repetition > 1 ? " (\#$repetition)" : ''));
  53     my $ok=0;
  54
  55     if (@_ == 0) {
  56         print "not ok $ntest\n";
  57         print "# test $context: DOESN'T TEST ANYTHING!\n";
  58     } else {
  59         my $result = to_value(shift);
  60         my ($expected,$diag);
  61         if (@_ == 0) {
  62             $ok = $result;
  63         } else {
  64             $expected = to_value(shift);
  65             $ok = $result eq $expected;
  66         }
  67         if ($todo{$ntest}) {
  68             if ($ok) {
  69                 print "ok $ntest # Wow!\n";
  70             } else {
  71                 $diag = to_value(shift) if @_;
  72                 if (!$diag) {
  73                     print "not ok $ntest # (failure expected)\n";
  74                 } else {
  75                     print "not ok $ntest # (failure expected: $diag)\n";
  76                 }
  77             }
  78         } else {
  79             print "not " if !$ok;
  80             print "ok $ntest\n";
  81
  82             if (!$ok) {
  83                 $diag = to_value(shift) if @_;
  84                 if (!defined $expected) {
  85                     if (!$diag) {
  86                         print STDERR "# Failed $context\n";
  87                     } else {
  88                         print STDERR "# Failed $context: $diag\n";
  89                     }
  90                 } else {
  91                     print STDERR "#      Got: '$result' ($context)\n";
  92                     if (!$diag) {
  93                         print STDERR "# Expected: '$expected'\n";
  94                     } else {
  95                         print STDERR "# Expected: '$expected' ($diag)\n";
  96                     }
  97                 }
  98             }
  99         }
 100     }
 101     ++ $ntest;
 102     $ok;
 103 }
 104
 105 sub skip {
 106     if (to_value(shift)) {
 107         print "ok $ntest # skip\n";
 108         ++ $ntest;
 109         1;
 110     } else {
 111         local($TestLevel) += 1;  #ignore this stack frame
 112         ok(@_);
 113     }
 114 }
 115
 116 1;
 117 __END__
 118
 119 =head1 NAME
 120
 121   Test - provides a simple framework for writing test scripts
 122
 123 =head1 SYNOPSIS
 124
 125   use strict;
 126   use Test;
 127   BEGIN { plan tests => 12, todo => [3,4] }
 128
 129   ok(0); # failure
 130   ok(1); # success
 131
 132   ok(0); # ok, expected failure (see todo list, above)
 133   ok(1); # surprise success!
 134
 135   ok(0,1);             # failure: '0' ne '1'
 136   ok('broke','fixed'); # failure: 'broke' ne 'fixed'
 137   ok('fixed','fixed'); # success: 'fixed' eq 'fixed'
 138
 139   ok(sub { 1+1 }, 2);  # success: '2' eq '2'
 140   ok(sub { 1+1 }, 3);  # failure: '2' ne '3'
 141   ok(0, int(rand(2));  # (just kidding! :-)
 142
 143   my @list = (0,0);
 144   ok(scalar(@list), 3, "\@list=".join(',',@list));  #extra diagnostics
 145
 146   skip($feature_is_missing, ...);    #do platform specific test
 147
 148 =head1 DESCRIPTION
 149
 150 Test::Harness expects to see particular output when it executes tests.
 151 This module aims to make writing proper test scripts just a little bit
 152 easier (and less error prone :-).
 153
 154 =head1 TEST TYPES
 155
 156 =over 4
 157
 158 =item * NORMAL TESTS
 159
 160 These tests are expected to succeed.  If they don't, something's
 161 screwed up!
 162
 163 =item * SKIPPED TESTS
 164
 165 Skip tests need a platform specific feature that might or might not be
 166 available.  The first argument should evaluate to true if the required
 167 feature is NOT available.  After the first argument, skip tests work
 168 exactly the same way as do normal tests.
 169
 170 =item * TODO TESTS
 171
 172 TODO tests are designed for maintaining an executable TODO list.
 173 These tests are expected NOT to succeed (otherwise the feature they
 174 test would be on the new feature list, not the TODO list).
 175
 176 Packages should NOT be released with successful TODO tests.  As soon
 177 as a TODO test starts working, it should be promoted to a normal test
 178 and the new feature should be documented in the release notes.
 179
 180 =back
 181
 182 =head1 SEE ALSO
 183
 184 L<Test::Harness> and various test coverage analysis tools.
 185
 186 =head1 AUTHOR
 187
 188 Copyright © 1998 Joshua Nathaniel Pritikin.  All rights reserved.
 189
 190 This package is free software and is provided "as is" without express
 191 or implied warranty.  It may be used, redistributed and/or modified
 192 under the terms of the Perl Artistic License (see
 193 http://www.perl.com/perl/misc/Artistic.html)
 194
 195 =cut