Commit | Line | Data |
7b13a3f5 |
1 | use strict; |
2 | package Test; |
3 | use Test::Harness 1.1601 (); |
4 | use Carp; |
f2ac83ee |
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.121'; |
7b13a3f5 |
8 | require Exporter; |
9 | @ISA=('Exporter'); |
f2ac83ee |
10 | @EXPORT=qw(&plan &ok &skip); |
11 | @EXPORT_OK=qw($ntest $TESTOUT); |
7b13a3f5 |
12 | |
3238f5fe |
13 | $TestLevel = 0; # how many extra stack frames to skip |
7b13a3f5 |
14 | $|=1; |
15 | #$^W=1; ? |
16 | $ntest=1; |
f2ac83ee |
17 | $TESTOUT = *STDOUT{IO}; |
7b13a3f5 |
18 | |
3238f5fe |
19 | # Use of this variable is strongly discouraged. It is set mainly to |
20 | # help test coverage analyzers know which test is running. |
7b13a3f5 |
21 | $ENV{REGRESSION_TEST} = $0; |
22 | |
23 | sub plan { |
24 | croak "Test::plan(%args): odd number of arguments" if @_ & 1; |
8b3be1d1 |
25 | croak "Test::plan(): should not be called more than once" if $planned; |
7b13a3f5 |
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; }; } |
8b3be1d1 |
32 | elsif ($k eq 'onfail') { |
33 | ref $v eq 'CODE' or croak "Test::plan(onfail => $v): must be CODE"; |
34 | $ONFAIL = $v; |
35 | } |
7b13a3f5 |
36 | else { carp "Test::plan(): skipping unrecognized directive '$k'" } |
37 | } |
38 | my @todo = sort { $a <=> $b } keys %todo; |
39 | if (@todo) { |
f2ac83ee |
40 | print $TESTOUT "1..$max todo ".join(' ', @todo).";\n"; |
7b13a3f5 |
41 | } else { |
f2ac83ee |
42 | print $TESTOUT "1..$max\n"; |
7b13a3f5 |
43 | } |
8b3be1d1 |
44 | ++$planned; |
7b13a3f5 |
45 | } |
46 | |
3238f5fe |
47 | sub to_value { |
48 | my ($v) = @_; |
49 | (ref $v or '') eq 'CODE' ? $v->() : $v; |
50 | } |
51 | |
8b3be1d1 |
52 | sub ok ($;$$) { |
53 | croak "ok: plan before you test!" if !$planned; |
3238f5fe |
54 | my ($pkg,$file,$line) = caller($TestLevel); |
55 | my $repetition = ++$history{"$file:$line"}; |
56 | my $context = ("$file at line $line". |
8b3be1d1 |
57 | ($repetition > 1 ? " fail \#$repetition" : '')); |
3238f5fe |
58 | my $ok=0; |
8b3be1d1 |
59 | my $result = to_value(shift); |
60 | my ($expected,$diag); |
3238f5fe |
61 | if (@_ == 0) { |
8b3be1d1 |
62 | $ok = $result; |
3238f5fe |
63 | } else { |
8b3be1d1 |
64 | $expected = to_value(shift); |
8b3be1d1 |
65 | my ($regex,$ignore); |
f63ceb1c |
66 | if ((ref($expected)||'') eq 'Regexp') { |
f2ac83ee |
67 | $ok = $result =~ /$expected/; |
68 | } elsif (($regex) = ($expected =~ m,^ / (.+) / $,sx) or |
8b3be1d1 |
69 | ($ignore, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) { |
70 | $ok = $result =~ /$regex/; |
3238f5fe |
71 | } else { |
3238f5fe |
72 | $ok = $result eq $expected; |
73 | } |
8b3be1d1 |
74 | } |
f2ac83ee |
75 | my $todo = $todo{$ntest}; |
76 | if ($todo and $ok) { |
77 | $context .= ' TODO?!' if $todo; |
78 | print $TESTOUT "ok $ntest # ($context)\n"; |
8b3be1d1 |
79 | } else { |
f2ac83ee |
80 | print $TESTOUT "not " if !$ok; |
81 | print $TESTOUT "ok $ntest\n"; |
8b3be1d1 |
82 | |
83 | if (!$ok) { |
84 | my $detail = { 'repetition' => $repetition, 'package' => $pkg, |
f2ac83ee |
85 | 'result' => $result, 'todo' => $todo }; |
8b3be1d1 |
86 | $$detail{expected} = $expected if defined $expected; |
87 | $diag = $$detail{diagnostic} = to_value(shift) if @_; |
f2ac83ee |
88 | $context .= ' *TODO*' if $todo; |
8b3be1d1 |
89 | if (!defined $expected) { |
3238f5fe |
90 | if (!$diag) { |
f2ac83ee |
91 | print $TESTOUT "# Failed test $ntest in $context\n"; |
3238f5fe |
92 | } else { |
f2ac83ee |
93 | print $TESTOUT "# Failed test $ntest in $context: $diag\n"; |
3238f5fe |
94 | } |
8b3be1d1 |
95 | } else { |
96 | my $prefix = "Test $ntest"; |
f2ac83ee |
97 | print $TESTOUT "# $prefix got: '$result' ($context)\n"; |
8b3be1d1 |
98 | $prefix = ' ' x (length($prefix) - 5); |
f63ceb1c |
99 | if ((ref($expected)||'') eq 'Regexp') { |
f2ac83ee |
100 | $expected = 'qr/'.$expected.'/' |
101 | } else { |
102 | $expected = "'$expected'"; |
103 | } |
8b3be1d1 |
104 | if (!$diag) { |
f2ac83ee |
105 | print $TESTOUT "# $prefix Expected: $expected\n"; |
3238f5fe |
106 | } else { |
f2ac83ee |
107 | print $TESTOUT "# $prefix Expected: $expected ($diag)\n"; |
3238f5fe |
108 | } |
109 | } |
8b3be1d1 |
110 | push @FAILDETAIL, $detail; |
7b13a3f5 |
111 | } |
7b13a3f5 |
112 | } |
113 | ++ $ntest; |
114 | $ok; |
115 | } |
116 | |
8b3be1d1 |
117 | sub skip ($$;$$) { |
f2ac83ee |
118 | my $whyskip = to_value(shift); |
119 | if ($whyskip) { |
120 | $whyskip = 'skip' if $whyskip =~ m/^\d+$/; |
121 | print $TESTOUT "ok $ntest # $whyskip\n"; |
7b13a3f5 |
122 | ++ $ntest; |
123 | 1; |
124 | } else { |
8b3be1d1 |
125 | local($TestLevel) = $TestLevel+1; #ignore this stack frame |
126 | &ok; |
7b13a3f5 |
127 | } |
128 | } |
129 | |
8b3be1d1 |
130 | END { |
131 | $ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL; |
132 | } |
133 | |
7b13a3f5 |
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; |
f2ac83ee |
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; |
3238f5fe |
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' |
f2ac83ee |
161 | ok('fixed',qr/x/); # success: 'fixed' =~ qr/x/ |
7b13a3f5 |
162 | |
3238f5fe |
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! :-) |
7b13a3f5 |
166 | |
3238f5fe |
167 | my @list = (0,0); |
8b3be1d1 |
168 | ok @list, 3, "\@list=".join(',',@list); #extra diagnostics |
169 | ok 'segmentation fault', '/(?i)success/'; #regex match |
7b13a3f5 |
170 | |
3238f5fe |
171 | skip($feature_is_missing, ...); #do platform specific test |
7b13a3f5 |
172 | |
173 | =head1 DESCRIPTION |
174 | |
f2ac83ee |
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 :-). |
7b13a3f5 |
178 | |
3238f5fe |
179 | =head1 TEST TYPES |
7b13a3f5 |
180 | |
181 | =over 4 |
182 | |
183 | =item * NORMAL TESTS |
184 | |
f2ac83ee |
185 | These tests are expected to succeed. If they don't something's |
3238f5fe |
186 | screwed up! |
7b13a3f5 |
187 | |
188 | =item * SKIPPED TESTS |
189 | |
f2ac83ee |
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 |
3238f5fe |
194 | exactly the same way as do normal tests. |
7b13a3f5 |
195 | |
196 | =item * TODO TESTS |
197 | |
f2ac83ee |
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? |
7b13a3f5 |
201 | |
f2ac83ee |
202 | Packages should NOT be released with succeeding TODO tests. As soon |
7b13a3f5 |
203 | as a TODO test starts working, it should be promoted to a normal test |
f2ac83ee |
204 | and the newly working feature should be documented in the release |
205 | notes or change log. |
7b13a3f5 |
206 | |
207 | =back |
208 | |
f2ac83ee |
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 | |
8b3be1d1 |
214 | =head1 ONFAIL |
215 | |
216 | BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } } |
217 | |
f2ac83ee |
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 |
8b3be1d1 |
234 | than the code it is testing, yes?) |
235 | |
7b13a3f5 |
236 | =head1 SEE ALSO |
237 | |
f2ac83ee |
238 | L<Test::Harness> and, perhaps, test coverage analysis tools. |
7b13a3f5 |
239 | |
240 | =head1 AUTHOR |
241 | |
f31700dc |
242 | Copyright (C) 1998 Joshua Nathaniel Pritikin. All rights reserved. |
7b13a3f5 |
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 |