Commit | Line | Data |
7b13a3f5 |
1 | use strict; |
2 | package Test; |
3 | use Test::Harness 1.1601 (); |
4 | use Carp; |
3238f5fe |
5 | use vars qw($VERSION @ISA @EXPORT $ntest %todo %history $TestLevel); |
6 | $VERSION = '0.08'; |
7b13a3f5 |
7 | require Exporter; |
8 | @ISA=('Exporter'); |
9 | @EXPORT= qw(&plan &ok &skip $ntest); |
10 | |
3238f5fe |
11 | $TestLevel = 0; # how many extra stack frames to skip |
7b13a3f5 |
12 | $|=1; |
13 | #$^W=1; ? |
14 | $ntest=1; |
15 | |
3238f5fe |
16 | # Use of this variable is strongly discouraged. It is set mainly to |
17 | # help test coverage analyzers know which test is running. |
7b13a3f5 |
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 | |
3238f5fe |
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 | |
7b13a3f5 |
48 | sub ok { |
3238f5fe |
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 | } |
7b13a3f5 |
67 | if ($todo{$ntest}) { |
3238f5fe |
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 | } |
7b13a3f5 |
78 | } else { |
3238f5fe |
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 | } |
7b13a3f5 |
99 | } |
7b13a3f5 |
100 | } |
101 | ++ $ntest; |
102 | $ok; |
103 | } |
104 | |
105 | sub skip { |
3238f5fe |
106 | if (to_value(shift)) { |
7b13a3f5 |
107 | print "ok $ntest # skip\n"; |
108 | ++ $ntest; |
109 | 1; |
110 | } else { |
3238f5fe |
111 | local($TestLevel) += 1; #ignore this stack frame |
112 | ok(@_); |
7b13a3f5 |
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; |
3238f5fe |
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' |
7b13a3f5 |
138 | |
3238f5fe |
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! :-) |
7b13a3f5 |
142 | |
3238f5fe |
143 | my @list = (0,0); |
144 | ok(scalar(@list), 3, "\@list=".join(',',@list)); #extra diagnostics |
7b13a3f5 |
145 | |
3238f5fe |
146 | skip($feature_is_missing, ...); #do platform specific test |
7b13a3f5 |
147 | |
148 | =head1 DESCRIPTION |
149 | |
3238f5fe |
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 :-). |
7b13a3f5 |
153 | |
3238f5fe |
154 | =head1 TEST TYPES |
7b13a3f5 |
155 | |
156 | =over 4 |
157 | |
158 | =item * NORMAL TESTS |
159 | |
3238f5fe |
160 | These tests are expected to succeed. If they don't, something's |
161 | screwed up! |
7b13a3f5 |
162 | |
163 | =item * SKIPPED TESTS |
164 | |
3238f5fe |
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. |
7b13a3f5 |
169 | |
170 | =item * TODO TESTS |
171 | |
3238f5fe |
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). |
7b13a3f5 |
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 |