Commit | Line | Data |
---|---|---|
7b13a3f5 JP |
1 | use strict; |
2 | package Test; | |
3 | use Test::Harness 1.1601 (); | |
4 | use Carp; | |
8b3be1d1 JP |
5 | use vars (qw($VERSION @ISA @EXPORT $ntest $TestLevel), #public-ish |
6 | qw($ONFAIL %todo %history $planned @FAILDETAIL)); #private-ish | |
7 | $VERSION = '1.04'; | |
7b13a3f5 JP |
8 | require Exporter; |
9 | @ISA=('Exporter'); | |
10 | @EXPORT= qw(&plan &ok &skip $ntest); | |
11 | ||
3238f5fe | 12 | $TestLevel = 0; # how many extra stack frames to skip |
7b13a3f5 JP |
13 | $|=1; |
14 | #$^W=1; ? | |
15 | $ntest=1; | |
16 | ||
3238f5fe JP |
17 | # Use of this variable is strongly discouraged. It is set mainly to |
18 | # help test coverage analyzers know which test is running. | |
7b13a3f5 JP |
19 | $ENV{REGRESSION_TEST} = $0; |
20 | ||
21 | sub plan { | |
22 | croak "Test::plan(%args): odd number of arguments" if @_ & 1; | |
8b3be1d1 | 23 | croak "Test::plan(): should not be called more than once" if $planned; |
7b13a3f5 JP |
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; }; } | |
8b3be1d1 JP |
30 | elsif ($k eq 'onfail') { |
31 | ref $v eq 'CODE' or croak "Test::plan(onfail => $v): must be CODE"; | |
32 | $ONFAIL = $v; | |
33 | } | |
7b13a3f5 JP |
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 | } | |
8b3be1d1 | 42 | ++$planned; |
7b13a3f5 JP |
43 | } |
44 | ||
3238f5fe JP |
45 | sub to_value { |
46 | my ($v) = @_; | |
47 | (ref $v or '') eq 'CODE' ? $v->() : $v; | |
48 | } | |
49 | ||
8b3be1d1 JP |
50 | # STDERR is NOT used for diagnostic output which should have been |
51 | # fixed before release. Is this appropriate? | |
3238f5fe | 52 | |
8b3be1d1 JP |
53 | sub ok ($;$$) { |
54 | croak "ok: plan before you test!" if !$planned; | |
3238f5fe JP |
55 | my ($pkg,$file,$line) = caller($TestLevel); |
56 | my $repetition = ++$history{"$file:$line"}; | |
57 | my $context = ("$file at line $line". | |
8b3be1d1 | 58 | ($repetition > 1 ? " fail \#$repetition" : '')); |
3238f5fe | 59 | my $ok=0; |
8b3be1d1 JP |
60 | my $result = to_value(shift); |
61 | my ($expected,$diag); | |
3238f5fe | 62 | if (@_ == 0) { |
8b3be1d1 | 63 | $ok = $result; |
3238f5fe | 64 | } else { |
8b3be1d1 JP |
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/; | |
3238f5fe | 71 | } else { |
3238f5fe JP |
72 | $ok = $result eq $expected; |
73 | } | |
8b3be1d1 JP |
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"; | |
3238f5fe | 82 | } else { |
8b3be1d1 JP |
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) { | |
3238f5fe | 96 | if (!$diag) { |
8b3be1d1 | 97 | print STDERR "# Failed test $ntest in $context\n"; |
3238f5fe | 98 | } else { |
8b3be1d1 | 99 | print STDERR "# Failed test $ntest in $context: $diag\n"; |
3238f5fe | 100 | } |
8b3be1d1 JP |
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"; | |
3238f5fe | 107 | } else { |
8b3be1d1 | 108 | print STDERR "# $prefix Expected: '$expected' ($diag)\n"; |
3238f5fe JP |
109 | } |
110 | } | |
8b3be1d1 | 111 | push @FAILDETAIL, $detail; |
7b13a3f5 | 112 | } |
7b13a3f5 JP |
113 | } |
114 | ++ $ntest; | |
115 | $ok; | |
116 | } | |
117 | ||
8b3be1d1 | 118 | sub skip ($$;$$) { |
3238f5fe | 119 | if (to_value(shift)) { |
7b13a3f5 JP |
120 | print "ok $ntest # skip\n"; |
121 | ++ $ntest; | |
122 | 1; | |
123 | } else { | |
8b3be1d1 JP |
124 | local($TestLevel) = $TestLevel+1; #ignore this stack frame |
125 | &ok; | |
7b13a3f5 JP |
126 | } |
127 | } | |
128 | ||
8b3be1d1 JP |
129 | END { |
130 | $ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL; | |
131 | } | |
132 | ||
7b13a3f5 JP |
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; | |
8b3be1d1 | 144 | BEGIN { plan tests => 13, todo => [3,4] } |
3238f5fe JP |
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' | |
7b13a3f5 | 155 | |
3238f5fe JP |
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! :-) | |
7b13a3f5 | 159 | |
3238f5fe | 160 | my @list = (0,0); |
8b3be1d1 JP |
161 | ok @list, 3, "\@list=".join(',',@list); #extra diagnostics |
162 | ok 'segmentation fault', '/(?i)success/'; #regex match | |
7b13a3f5 | 163 | |
3238f5fe | 164 | skip($feature_is_missing, ...); #do platform specific test |
7b13a3f5 JP |
165 | |
166 | =head1 DESCRIPTION | |
167 | ||
3238f5fe JP |
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 :-). | |
7b13a3f5 | 171 | |
3238f5fe | 172 | =head1 TEST TYPES |
7b13a3f5 JP |
173 | |
174 | =over 4 | |
175 | ||
176 | =item * NORMAL TESTS | |
177 | ||
3238f5fe JP |
178 | These tests are expected to succeed. If they don't, something's |
179 | screwed up! | |
7b13a3f5 JP |
180 | |
181 | =item * SKIPPED TESTS | |
182 | ||
3238f5fe JP |
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. | |
7b13a3f5 JP |
187 | |
188 | =item * TODO TESTS | |
189 | ||
3238f5fe JP |
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). | |
7b13a3f5 JP |
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 | |
8b3be1d1 JP |
196 | and the newly minted feature should be documented in the release |
197 | notes. | |
7b13a3f5 JP |
198 | |
199 | =back | |
200 | ||
8b3be1d1 JP |
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 | ||
7b13a3f5 JP |
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 |