line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Test::More; |
2
|
|
|
|
|
|
|
|
3
|
128
|
|
|
128
|
|
95060
|
use 5.006; |
|
128
|
|
|
|
|
937
|
|
4
|
128
|
|
|
128
|
|
742
|
use strict; |
|
128
|
|
|
|
|
310
|
|
|
128
|
|
|
|
|
2898
|
|
5
|
128
|
|
|
128
|
|
765
|
use warnings; |
|
128
|
|
|
|
|
322
|
|
|
128
|
|
|
|
|
17511
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
#---- perlcritic exemptions. ----# |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
# We use a lot of subroutine prototypes |
10
|
|
|
|
|
|
|
## no critic (Subroutines::ProhibitSubroutinePrototypes) |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
# Can't use Carp because it might cause C<use_ok()> to accidentally succeed |
13
|
|
|
|
|
|
|
# even though the module being used forgot to use Carp. Yes, this |
14
|
|
|
|
|
|
|
# actually happened. |
15
|
|
|
|
|
|
|
sub _carp { |
16
|
7
|
|
|
8
|
|
52
|
my( $file, $line ) = ( caller(1) )[ 1, 2 ]; |
17
|
7
|
|
|
|
|
88
|
return warn @_, " at $file line $line\n"; |
18
|
|
|
|
|
|
|
} |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
our $VERSION = '1.302182'; |
21
|
|
|
|
|
|
|
|
22
|
128
|
|
|
128
|
|
54380
|
use Test::Builder::Module; |
|
127
|
|
|
|
|
414
|
|
|
127
|
|
|
|
|
867
|
|
23
|
|
|
|
|
|
|
our @ISA = qw(Test::Builder::Module); |
24
|
|
|
|
|
|
|
our @EXPORT = qw(ok use_ok require_ok |
25
|
|
|
|
|
|
|
is isnt like unlike is_deeply |
26
|
|
|
|
|
|
|
cmp_ok |
27
|
|
|
|
|
|
|
skip todo todo_skip |
28
|
|
|
|
|
|
|
pass fail |
29
|
|
|
|
|
|
|
eq_array eq_hash eq_set |
30
|
|
|
|
|
|
|
$TODO |
31
|
|
|
|
|
|
|
plan |
32
|
|
|
|
|
|
|
done_testing |
33
|
|
|
|
|
|
|
can_ok isa_ok new_ok |
34
|
|
|
|
|
|
|
diag note explain |
35
|
|
|
|
|
|
|
subtest |
36
|
|
|
|
|
|
|
BAIL_OUT |
37
|
|
|
|
|
|
|
); |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
=head1 NAME |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
Test::More - yet another framework for writing test scripts |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
=head1 SYNOPSIS |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
use Test::More tests => 23; |
46
|
|
|
|
|
|
|
# or |
47
|
|
|
|
|
|
|
use Test::More skip_all => $reason; |
48
|
|
|
|
|
|
|
# or |
49
|
|
|
|
|
|
|
use Test::More; # see done_testing() |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
require_ok( 'Some::Module' ); |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
# Various ways to say "ok" |
54
|
|
|
|
|
|
|
ok($got eq $expected, $test_name); |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
is ($got, $expected, $test_name); |
57
|
|
|
|
|
|
|
isnt($got, $expected, $test_name); |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
# Rather than print STDERR "# here's what went wrong\n" |
60
|
|
|
|
|
|
|
diag("here's what went wrong"); |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
like ($got, qr/expected/, $test_name); |
63
|
|
|
|
|
|
|
unlike($got, qr/expected/, $test_name); |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
cmp_ok($got, '==', $expected, $test_name); |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
is_deeply($got_complex_structure, $expected_complex_structure, $test_name); |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
SKIP: { |
70
|
|
|
|
|
|
|
skip $why, $how_many unless $have_some_feature; |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
ok( foo(), $test_name ); |
73
|
|
|
|
|
|
|
is( foo(42), 23, $test_name ); |
74
|
|
|
|
|
|
|
}; |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
TODO: { |
77
|
|
|
|
|
|
|
local $TODO = $why; |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
ok( foo(), $test_name ); |
80
|
|
|
|
|
|
|
is( foo(42), 23, $test_name ); |
81
|
|
|
|
|
|
|
}; |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
can_ok($module, @methods); |
84
|
|
|
|
|
|
|
isa_ok($object, $class); |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
pass($test_name); |
87
|
|
|
|
|
|
|
fail($test_name); |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
BAIL_OUT($why); |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
# UNIMPLEMENTED!!! |
92
|
|
|
|
|
|
|
my @status = Test::More::status; |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
=head1 DESCRIPTION |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
B<STOP!> If you're just getting started writing tests, have a look at |
98
|
|
|
|
|
|
|
L<Test2::Suite> first. |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
This is a drop in replacement for Test::Simple which you can switch to once you |
101
|
|
|
|
|
|
|
get the hang of basic testing. |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
The purpose of this module is to provide a wide range of testing |
104
|
|
|
|
|
|
|
utilities. Various ways to say "ok" with better diagnostics, |
105
|
|
|
|
|
|
|
facilities to skip tests, test future features and compare complicated |
106
|
|
|
|
|
|
|
data structures. While you can do almost anything with a simple |
107
|
|
|
|
|
|
|
C<ok()> function, it doesn't provide good diagnostic output. |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
=head2 I love it when a plan comes together |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
Before anything else, you need a testing plan. This basically declares |
113
|
|
|
|
|
|
|
how many tests your script is going to run to protect against premature |
114
|
|
|
|
|
|
|
failure. |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
The preferred way to do this is to declare a plan when you C<use Test::More>. |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
use Test::More tests => 23; |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
There are cases when you will not know beforehand how many tests your |
121
|
|
|
|
|
|
|
script is going to run. In this case, you can declare your tests at |
122
|
|
|
|
|
|
|
the end. |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
use Test::More; |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
... run your tests ... |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
done_testing( $number_of_tests_run ); |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
B<NOTE> C<done_testing()> should never be called in an C<END { ... }> block. |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
Sometimes you really don't know how many tests were run, or it's too |
133
|
|
|
|
|
|
|
difficult to calculate. In which case you can leave off |
134
|
|
|
|
|
|
|
$number_of_tests_run. |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
In some cases, you'll want to completely skip an entire testing script. |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
use Test::More skip_all => $skip_reason; |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
Your script will declare a skip with the reason why you skipped and |
141
|
|
|
|
|
|
|
exit immediately with a zero (success). See L<Test::Harness> for |
142
|
|
|
|
|
|
|
details. |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
If you want to control what functions Test::More will export, you |
145
|
|
|
|
|
|
|
have to use the 'import' option. For example, to import everything |
146
|
|
|
|
|
|
|
but 'fail', you'd do: |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
use Test::More tests => 23, import => ['!fail']; |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
Alternatively, you can use the C<plan()> function. Useful for when you |
151
|
|
|
|
|
|
|
have to calculate the number of tests. |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
use Test::More; |
154
|
|
|
|
|
|
|
plan tests => keys %Stuff * 3; |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
or for deciding between running the tests at all: |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
use Test::More; |
159
|
|
|
|
|
|
|
if( $^O eq 'MacOS' ) { |
160
|
|
|
|
|
|
|
plan skip_all => 'Test irrelevant on MacOS'; |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
else { |
163
|
|
|
|
|
|
|
plan tests => 42; |
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
=cut |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
sub plan { |
169
|
84
|
|
|
84
|
1
|
2553
|
my $tb = Test::More->builder; |
170
|
|
|
|
|
|
|
|
171
|
84
|
|
|
|
|
330
|
return $tb->plan(@_); |
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
# This implements "use Test::More 'no_diag'" but the behavior is |
175
|
|
|
|
|
|
|
# deprecated. |
176
|
|
|
|
|
|
|
sub import_extra { |
177
|
110
|
|
|
110
|
1
|
263
|
my $class = shift; |
178
|
110
|
|
|
|
|
206
|
my $list = shift; |
179
|
|
|
|
|
|
|
|
180
|
110
|
|
|
|
|
242
|
my @other = (); |
181
|
110
|
|
|
|
|
207
|
my $idx = 0; |
182
|
110
|
|
|
|
|
192
|
my $import; |
183
|
110
|
|
|
|
|
224
|
while( $idx <= $#{$list} ) { |
|
212
|
|
|
|
|
621
|
|
184
|
102
|
|
|
|
|
292
|
my $item = $list->[$idx]; |
185
|
|
|
|
|
|
|
|
186
|
102
|
100
|
66
|
|
|
784
|
if( defined $item and $item eq 'no_diag' ) { |
|
|
100
|
66
|
|
|
|
|
187
|
1
|
|
|
|
|
4
|
$class->builder->no_diag(1); |
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
elsif( defined $item and $item eq 'import' ) { |
190
|
3
|
100
|
|
|
|
10
|
if ($import) { |
191
|
0
|
|
|
|
|
0
|
push @$import, @{$list->[ ++$idx ]}; |
|
0
|
|
|
|
|
0
|
|
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
else { |
194
|
3
|
|
|
|
|
6
|
$import = $list->[ ++$idx ]; |
195
|
3
|
|
|
|
|
7
|
push @other, $item, $import; |
196
|
|
|
|
|
|
|
} |
197
|
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
else { |
199
|
98
|
|
|
|
|
223
|
push @other, $item; |
200
|
|
|
|
|
|
|
} |
201
|
|
|
|
|
|
|
|
202
|
102
|
|
|
|
|
186
|
$idx++; |
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
|
205
|
110
|
|
|
|
|
312
|
@$list = @other; |
206
|
|
|
|
|
|
|
|
207
|
110
|
100
|
66
|
|
|
746
|
if ($class eq __PACKAGE__ && (!$import || grep $_ eq '$TODO', @$import)) { |
|
|
|
33
|
|
|
|
|
208
|
107
|
|
|
|
|
373
|
my $to = $class->builder->exported_to; |
209
|
127
|
|
|
128
|
|
1029
|
no strict 'refs'; |
|
127
|
|
|
|
|
318
|
|
|
127
|
|
|
|
|
420709
|
|
210
|
107
|
|
|
|
|
272
|
*{"$to\::TODO"} = \our $TODO; |
|
107
|
|
|
|
|
669
|
|
211
|
107
|
100
|
|
|
|
426
|
if ($import) { |
212
|
0
|
|
|
|
|
0
|
@$import = grep $_ ne '$TODO', @$import; |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
else { |
215
|
107
|
|
|
|
|
1166
|
push @$list, import => [grep $_ ne '$TODO', @EXPORT]; |
216
|
|
|
|
|
|
|
} |
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
|
219
|
110
|
|
|
|
|
366
|
return; |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
=over 4 |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
=item B<done_testing> |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
done_testing(); |
227
|
|
|
|
|
|
|
done_testing($number_of_tests); |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
If you don't know how many tests you're going to run, you can issue |
230
|
|
|
|
|
|
|
the plan when you're done running tests. |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
$number_of_tests is the same as C<plan()>, it's the number of tests you |
233
|
|
|
|
|
|
|
expected to run. You can omit this, in which case the number of tests |
234
|
|
|
|
|
|
|
you ran doesn't matter, just the fact that your tests ran to |
235
|
|
|
|
|
|
|
conclusion. |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
This is safer than and replaces the "no_plan" plan. |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
B<Note:> You must never put C<done_testing()> inside an C<END { ... }> block. |
240
|
|
|
|
|
|
|
The plan is there to ensure your test does not exit before testing has |
241
|
|
|
|
|
|
|
completed. If you use an END block you completely bypass this protection. |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
=back |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
=cut |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
sub done_testing { |
248
|
44
|
|
|
44
|
1
|
375
|
my $tb = Test::More->builder; |
249
|
44
|
|
|
|
|
226
|
$tb->done_testing(@_); |
250
|
|
|
|
|
|
|
} |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
=head2 Test names |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
By convention, each test is assigned a number in order. This is |
255
|
|
|
|
|
|
|
largely done automatically for you. However, it's often very useful to |
256
|
|
|
|
|
|
|
assign a name to each test. Which would you rather see: |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
ok 4 |
259
|
|
|
|
|
|
|
not ok 5 |
260
|
|
|
|
|
|
|
ok 6 |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
or |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
ok 4 - basic multi-variable |
265
|
|
|
|
|
|
|
not ok 5 - simple exponential |
266
|
|
|
|
|
|
|
ok 6 - force == mass * acceleration |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
The later gives you some idea of what failed. It also makes it easier |
269
|
|
|
|
|
|
|
to find the test in your script, simply search for "simple |
270
|
|
|
|
|
|
|
exponential". |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
All test functions take a name argument. It's optional, but highly |
273
|
|
|
|
|
|
|
suggested that you use it. |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
=head2 I'm ok, you're not ok. |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
The basic purpose of this module is to print out either "ok #" or "not |
278
|
|
|
|
|
|
|
ok #" depending on if a given test succeeded or failed. Everything |
279
|
|
|
|
|
|
|
else is just gravy. |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
All of the following print "ok" or "not ok" depending on if the test |
282
|
|
|
|
|
|
|
succeeded or failed. They all also return true or false, |
283
|
|
|
|
|
|
|
respectively. |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
=over 4 |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
=item B<ok> |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
ok($got eq $expected, $test_name); |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
This simply evaluates any expression (C<$got eq $expected> is just a |
292
|
|
|
|
|
|
|
simple example) and uses that to determine if the test succeeded or |
293
|
|
|
|
|
|
|
failed. A true expression passes, a false one fails. Very simple. |
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
For example: |
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
ok( $exp{9} == 81, 'simple exponential' ); |
298
|
|
|
|
|
|
|
ok( Film->can('db_Main'), 'set_db()' ); |
299
|
|
|
|
|
|
|
ok( $p->tests == 4, 'saw tests' ); |
300
|
|
|
|
|
|
|
ok( !grep(!defined $_, @items), 'all items defined' ); |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
(Mnemonic: "This is ok.") |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
$test_name is a very short description of the test that will be printed |
305
|
|
|
|
|
|
|
out. It makes it very easy to find a test in your script when it fails |
306
|
|
|
|
|
|
|
and gives others an idea of your intentions. $test_name is optional, |
307
|
|
|
|
|
|
|
but we B<very> strongly encourage its use. |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
Should an C<ok()> fail, it will produce some diagnostics: |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
not ok 18 - sufficient mucus |
312
|
|
|
|
|
|
|
# Failed test 'sufficient mucus' |
313
|
|
|
|
|
|
|
# in foo.t at line 42. |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
This is the same as L<Test::Simple>'s C<ok()> routine. |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
=cut |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
sub ok ($;$) { |
320
|
452
|
|
|
452
|
1
|
2869
|
my( $test, $name ) = @_; |
321
|
452
|
|
|
|
|
1763
|
my $tb = Test::More->builder; |
322
|
|
|
|
|
|
|
|
323
|
452
|
|
|
|
|
1353
|
return $tb->ok( $test, $name ); |
324
|
|
|
|
|
|
|
} |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
=item B<is> |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
=item B<isnt> |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
is ( $got, $expected, $test_name ); |
331
|
|
|
|
|
|
|
isnt( $got, $expected, $test_name ); |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
Similar to C<ok()>, C<is()> and C<isnt()> compare their two arguments |
334
|
|
|
|
|
|
|
with C<eq> and C<ne> respectively and use the result of that to |
335
|
|
|
|
|
|
|
determine if the test succeeded or failed. So these: |
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
# Is the ultimate answer 42? |
338
|
|
|
|
|
|
|
is( ultimate_answer(), 42, "Meaning of Life" ); |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
# $foo isn't empty |
341
|
|
|
|
|
|
|
isnt( $foo, '', "Got some foo" ); |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
are similar to these: |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
ok( ultimate_answer() eq 42, "Meaning of Life" ); |
346
|
|
|
|
|
|
|
ok( $foo ne '', "Got some foo" ); |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
C<undef> will only ever match C<undef>. So you can test a value |
349
|
|
|
|
|
|
|
against C<undef> like this: |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
is($not_defined, undef, "undefined as expected"); |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
(Mnemonic: "This is that." "This isn't that.") |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
So why use these? They produce better diagnostics on failure. C<ok()> |
356
|
|
|
|
|
|
|
cannot know what you are testing for (beyond the name), but C<is()> and |
357
|
|
|
|
|
|
|
C<isnt()> know what the test was and why it failed. For example this |
358
|
|
|
|
|
|
|
test: |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
my $foo = 'waffle'; my $bar = 'yarblokos'; |
361
|
|
|
|
|
|
|
is( $foo, $bar, 'Is foo the same as bar?' ); |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
Will produce something like this: |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
not ok 17 - Is foo the same as bar? |
366
|
|
|
|
|
|
|
# Failed test 'Is foo the same as bar?' |
367
|
|
|
|
|
|
|
# in foo.t at line 139. |
368
|
|
|
|
|
|
|
# got: 'waffle' |
369
|
|
|
|
|
|
|
# expected: 'yarblokos' |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
So you can figure out what went wrong without rerunning the test. |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
You are encouraged to use C<is()> and C<isnt()> over C<ok()> where possible, |
374
|
|
|
|
|
|
|
however do not be tempted to use them to find out if something is |
375
|
|
|
|
|
|
|
true or false! |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
# XXX BAD! |
378
|
|
|
|
|
|
|
is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' ); |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
This does not check if C<exists $brooklyn{tree}> is true, it checks if |
381
|
|
|
|
|
|
|
it returns 1. Very different. Similar caveats exist for false and 0. |
382
|
|
|
|
|
|
|
In these cases, use C<ok()>. |
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' ); |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
A simple call to C<isnt()> usually does not provide a strong test but there |
387
|
|
|
|
|
|
|
are cases when you cannot say much more about a value than that it is |
388
|
|
|
|
|
|
|
different from some other value: |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
new_ok $obj, "Foo"; |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
my $clone = $obj->clone; |
393
|
|
|
|
|
|
|
isa_ok $obj, "Foo", "Foo->clone"; |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
isnt $obj, $clone, "clone() produces a different object"; |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
For those grammatical pedants out there, there's an C<isn't()> |
398
|
|
|
|
|
|
|
function which is an alias of C<isnt()>. |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
=cut |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
sub is ($$;$) { |
403
|
171
|
|
|
171
|
1
|
3271239
|
my $tb = Test::More->builder; |
404
|
|
|
|
|
|
|
|
405
|
171
|
|
|
|
|
738
|
return $tb->is_eq(@_); |
406
|
|
|
|
|
|
|
} |
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
sub isnt ($$;$) { |
409
|
11
|
|
|
11
|
1
|
697
|
my $tb = Test::More->builder; |
410
|
|
|
|
|
|
|
|
411
|
11
|
|
|
|
|
103
|
return $tb->isnt_eq(@_); |
412
|
|
|
|
|
|
|
} |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
*isn't = \&isnt; |
415
|
|
|
|
|
|
|
# ' to unconfuse syntax higlighters |
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
=item B<like> |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
like( $got, qr/expected/, $test_name ); |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
Similar to C<ok()>, C<like()> matches $got against the regex C<qr/expected/>. |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
So this: |
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
like($got, qr/expected/, 'this is like that'); |
426
|
|
|
|
|
|
|
|
427
|
|
|
|
|
|
|
is similar to: |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
ok( $got =~ m/expected/, 'this is like that'); |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
(Mnemonic "This is like that".) |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
The second argument is a regular expression. It may be given as a |
434
|
|
|
|
|
|
|
regex reference (i.e. C<qr//>) or (for better compatibility with older |
435
|
|
|
|
|
|
|
perls) as a string that looks like a regex (alternative delimiters are |
436
|
|
|
|
|
|
|
currently not supported): |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
like( $got, '/expected/', 'this is like that' ); |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
Regex options may be placed on the end (C<'/expected/i'>). |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
Its advantages over C<ok()> are similar to that of C<is()> and C<isnt()>. Better |
443
|
|
|
|
|
|
|
diagnostics on failure. |
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
=cut |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
sub like ($$;$) { |
448
|
21
|
|
|
21
|
1
|
601
|
my $tb = Test::More->builder; |
449
|
|
|
|
|
|
|
|
450
|
21
|
|
|
|
|
115
|
return $tb->like(@_); |
451
|
|
|
|
|
|
|
} |
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
=item B<unlike> |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
unlike( $got, qr/expected/, $test_name ); |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
Works exactly as C<like()>, only it checks if $got B<does not> match the |
458
|
|
|
|
|
|
|
given pattern. |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
=cut |
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
sub unlike ($$;$) { |
463
|
5
|
|
|
5
|
1
|
45
|
my $tb = Test::More->builder; |
464
|
|
|
|
|
|
|
|
465
|
5
|
|
|
|
|
18
|
return $tb->unlike(@_); |
466
|
|
|
|
|
|
|
} |
467
|
|
|
|
|
|
|
|
468
|
|
|
|
|
|
|
=item B<cmp_ok> |
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
cmp_ok( $got, $op, $expected, $test_name ); |
471
|
|
|
|
|
|
|
|
472
|
|
|
|
|
|
|
Halfway between C<ok()> and C<is()> lies C<cmp_ok()>. This allows you |
473
|
|
|
|
|
|
|
to compare two arguments using any binary perl operator. The test |
474
|
|
|
|
|
|
|
passes if the comparison is true and fails otherwise. |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
# ok( $got eq $expected ); |
477
|
|
|
|
|
|
|
cmp_ok( $got, 'eq', $expected, 'this eq that' ); |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
# ok( $got == $expected ); |
480
|
|
|
|
|
|
|
cmp_ok( $got, '==', $expected, 'this == that' ); |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
# ok( $got && $expected ); |
483
|
|
|
|
|
|
|
cmp_ok( $got, '&&', $expected, 'this && that' ); |
484
|
|
|
|
|
|
|
...etc... |
485
|
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
Its advantage over C<ok()> is when the test fails you'll know what $got |
487
|
|
|
|
|
|
|
and $expected were: |
488
|
|
|
|
|
|
|
|
489
|
|
|
|
|
|
|
not ok 1 |
490
|
|
|
|
|
|
|
# Failed test in foo.t at line 12. |
491
|
|
|
|
|
|
|
# '23' |
492
|
|
|
|
|
|
|
# && |
493
|
|
|
|
|
|
|
# undef |
494
|
|
|
|
|
|
|
|
495
|
|
|
|
|
|
|
It's also useful in those cases where you are comparing numbers and |
496
|
|
|
|
|
|
|
C<is()>'s use of C<eq> will interfere: |
497
|
|
|
|
|
|
|
|
498
|
|
|
|
|
|
|
cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); |
499
|
|
|
|
|
|
|
|
500
|
|
|
|
|
|
|
It's especially useful when comparing greater-than or smaller-than |
501
|
|
|
|
|
|
|
relation between values: |
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
cmp_ok( $some_value, '<=', $upper_limit ); |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
=cut |
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
sub cmp_ok($$$;$) { |
509
|
36
|
|
|
36
|
1
|
41938
|
my $tb = Test::More->builder; |
510
|
|
|
|
|
|
|
|
511
|
36
|
|
|
|
|
133
|
return $tb->cmp_ok(@_); |
512
|
|
|
|
|
|
|
} |
513
|
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
=item B<can_ok> |
515
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
can_ok($module, @methods); |
517
|
|
|
|
|
|
|
can_ok($object, @methods); |
518
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
Checks to make sure the $module or $object can do these @methods |
520
|
|
|
|
|
|
|
(works with functions, too). |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
can_ok('Foo', qw(this that whatever)); |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
is almost exactly like saying: |
525
|
|
|
|
|
|
|
|
526
|
|
|
|
|
|
|
ok( Foo->can('this') && |
527
|
|
|
|
|
|
|
Foo->can('that') && |
528
|
|
|
|
|
|
|
Foo->can('whatever') |
529
|
|
|
|
|
|
|
); |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
only without all the typing and with a better interface. Handy for |
532
|
|
|
|
|
|
|
quickly testing an interface. |
533
|
|
|
|
|
|
|
|
534
|
|
|
|
|
|
|
No matter how many @methods you check, a single C<can_ok()> call counts |
535
|
|
|
|
|
|
|
as one test. If you desire otherwise, use: |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
foreach my $meth (@methods) { |
538
|
|
|
|
|
|
|
can_ok('Foo', $meth); |
539
|
|
|
|
|
|
|
} |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
=cut |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
sub can_ok ($@) { |
544
|
13
|
|
|
13
|
1
|
109
|
my( $proto, @methods ) = @_; |
545
|
13
|
|
100
|
|
|
71
|
my $class = ref $proto || $proto; |
546
|
13
|
|
|
|
|
70
|
my $tb = Test::More->builder; |
547
|
|
|
|
|
|
|
|
548
|
13
|
100
|
|
|
|
43
|
unless($class) { |
549
|
1
|
|
|
|
|
5
|
my $ok = $tb->ok( 0, "->can(...)" ); |
550
|
1
|
|
|
|
|
5
|
$tb->diag(' can_ok() called with empty class or reference'); |
551
|
1
|
|
|
|
|
4
|
return $ok; |
552
|
|
|
|
|
|
|
} |
553
|
|
|
|
|
|
|
|
554
|
12
|
100
|
|
|
|
43
|
unless(@methods) { |
555
|
1
|
|
|
|
|
6
|
my $ok = $tb->ok( 0, "$class->can(...)" ); |
556
|
1
|
|
|
|
|
5
|
$tb->diag(' can_ok() called with no methods'); |
557
|
1
|
|
|
|
|
15
|
return $ok; |
558
|
|
|
|
|
|
|
} |
559
|
|
|
|
|
|
|
|
560
|
11
|
|
|
|
|
26
|
my @nok = (); |
561
|
11
|
|
|
|
|
30
|
foreach my $method (@methods) { |
562
|
41
|
100
|
|
41
|
|
386
|
$tb->_try( sub { $proto->can($method) } ) or push @nok, $method; |
|
41
|
|
|
|
|
203
|
|
563
|
|
|
|
|
|
|
} |
564
|
|
|
|
|
|
|
|
565
|
11
|
100
|
|
|
|
58
|
my $name = (@methods == 1) ? "$class->can('$methods[0]')" : |
566
|
|
|
|
|
|
|
"$class->can(...)" ; |
567
|
|
|
|
|
|
|
|
568
|
11
|
|
|
|
|
49
|
my $ok = $tb->ok( !@nok, $name ); |
569
|
|
|
|
|
|
|
|
570
|
11
|
|
|
|
|
76
|
$tb->diag( map " $class->can('$_') failed\n", @nok ); |
571
|
|
|
|
|
|
|
|
572
|
11
|
|
|
|
|
39
|
return $ok; |
573
|
|
|
|
|
|
|
} |
574
|
|
|
|
|
|
|
|
575
|
|
|
|
|
|
|
=item B<isa_ok> |
576
|
|
|
|
|
|
|
|
577
|
|
|
|
|
|
|
isa_ok($object, $class, $object_name); |
578
|
|
|
|
|
|
|
isa_ok($subclass, $class, $object_name); |
579
|
|
|
|
|
|
|
isa_ok($ref, $type, $ref_name); |
580
|
|
|
|
|
|
|
|
581
|
|
|
|
|
|
|
Checks to see if the given C<< $object->isa($class) >>. Also checks to make |
582
|
|
|
|
|
|
|
sure the object was defined in the first place. Handy for this sort |
583
|
|
|
|
|
|
|
of thing: |
584
|
|
|
|
|
|
|
|
585
|
|
|
|
|
|
|
my $obj = Some::Module->new; |
586
|
|
|
|
|
|
|
isa_ok( $obj, 'Some::Module' ); |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
where you'd otherwise have to write |
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
my $obj = Some::Module->new; |
591
|
|
|
|
|
|
|
ok( defined $obj && $obj->isa('Some::Module') ); |
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
to safeguard against your test script blowing up. |
594
|
|
|
|
|
|
|
|
595
|
|
|
|
|
|
|
You can also test a class, to make sure that it has the right ancestor: |
596
|
|
|
|
|
|
|
|
597
|
|
|
|
|
|
|
isa_ok( 'Vole', 'Rodent' ); |
598
|
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
It works on references, too: |
600
|
|
|
|
|
|
|
|
601
|
|
|
|
|
|
|
isa_ok( $array_ref, 'ARRAY' ); |
602
|
|
|
|
|
|
|
|
603
|
|
|
|
|
|
|
The diagnostics of this test normally just refer to 'the object'. If |
604
|
|
|
|
|
|
|
you'd like them to be more specific, you can supply an $object_name |
605
|
|
|
|
|
|
|
(for example 'Test customer'). |
606
|
|
|
|
|
|
|
|
607
|
|
|
|
|
|
|
=cut |
608
|
|
|
|
|
|
|
|
609
|
|
|
|
|
|
|
sub isa_ok ($$;$) { |
610
|
33
|
|
|
33
|
1
|
265
|
my( $thing, $class, $thing_name ) = @_; |
611
|
33
|
|
|
|
|
193
|
my $tb = Test::More->builder; |
612
|
|
|
|
|
|
|
|
613
|
33
|
|
|
|
|
58
|
my $whatami; |
614
|
33
|
100
|
|
|
|
127
|
if( !defined $thing ) { |
|
|
100
|
|
|
|
|
|
615
|
2
|
|
|
|
|
4
|
$whatami = 'undef'; |
616
|
|
|
|
|
|
|
} |
617
|
|
|
|
|
|
|
elsif( ref $thing ) { |
618
|
27
|
|
|
|
|
54
|
$whatami = 'reference'; |
619
|
|
|
|
|
|
|
|
620
|
27
|
|
|
|
|
98
|
local($@,$!); |
621
|
27
|
|
|
|
|
172
|
require Scalar::Util; |
622
|
27
|
100
|
|
|
|
130
|
if( Scalar::Util::blessed($thing) ) { |
623
|
23
|
|
|
|
|
72
|
$whatami = 'object'; |
624
|
|
|
|
|
|
|
} |
625
|
|
|
|
|
|
|
} |
626
|
|
|
|
|
|
|
else { |
627
|
4
|
|
|
|
|
10
|
$whatami = 'class'; |
628
|
|
|
|
|
|
|
} |
629
|
|
|
|
|
|
|
|
630
|
|
|
|
|
|
|
# We can't use UNIVERSAL::isa because we want to honor isa() overrides |
631
|
33
|
|
|
33
|
|
201
|
my( $rslt, $error ) = $tb->_try( sub { $thing->isa($class) } ); |
|
33
|
|
|
|
|
244
|
|
632
|
|
|
|
|
|
|
|
633
|
33
|
100
|
|
|
|
145
|
if($error) { |
634
|
6
|
50
|
|
|
|
63
|
die <<WHOA unless $error =~ /^Can't (locate|call) method "isa"/; |
635
|
|
|
|
|
|
|
WHOA! I tried to call ->isa on your $whatami and got some weird error. |
636
|
|
|
|
|
|
|
Here's the error. |
637
|
|
|
|
|
|
|
$error |
638
|
|
|
|
|
|
|
WHOA |
639
|
|
|
|
|
|
|
} |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
# Special case for isa_ok( [], "ARRAY" ) and like |
642
|
33
|
100
|
|
|
|
91
|
if( $whatami eq 'reference' ) { |
643
|
4
|
|
|
|
|
25
|
$rslt = UNIVERSAL::isa($thing, $class); |
644
|
|
|
|
|
|
|
} |
645
|
|
|
|
|
|
|
|
646
|
33
|
|
|
|
|
68
|
my($diag, $name); |
647
|
33
|
100
|
|
|
|
128
|
if( defined $thing_name ) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
648
|
4
|
|
|
|
|
16
|
$name = "'$thing_name' isa '$class'"; |
649
|
4
|
100
|
|
|
|
20
|
$diag = defined $thing ? "'$thing_name' isn't a '$class'" : "'$thing_name' isn't defined"; |
650
|
|
|
|
|
|
|
} |
651
|
|
|
|
|
|
|
elsif( $whatami eq 'object' ) { |
652
|
21
|
|
|
|
|
45
|
my $my_class = ref $thing; |
653
|
21
|
|
|
|
|
60
|
$thing_name = qq[An object of class '$my_class']; |
654
|
21
|
|
|
|
|
54
|
$name = "$thing_name isa '$class'"; |
655
|
21
|
|
|
|
|
66
|
$diag = "The object of class '$my_class' isn't a '$class'"; |
656
|
|
|
|
|
|
|
} |
657
|
|
|
|
|
|
|
elsif( $whatami eq 'reference' ) { |
658
|
4
|
|
|
|
|
9
|
my $type = ref $thing; |
659
|
4
|
|
|
|
|
14
|
$thing_name = qq[A reference of type '$type']; |
660
|
4
|
|
|
|
|
10
|
$name = "$thing_name isa '$class'"; |
661
|
4
|
|
|
|
|
12
|
$diag = "The reference of type '$type' isn't a '$class'"; |
662
|
|
|
|
|
|
|
} |
663
|
|
|
|
|
|
|
elsif( $whatami eq 'undef' ) { |
664
|
1
|
|
|
|
|
3
|
$thing_name = 'undef'; |
665
|
1
|
|
|
|
|
5
|
$name = "$thing_name isa '$class'"; |
666
|
1
|
|
|
|
|
2
|
$diag = "$thing_name isn't defined"; |
667
|
|
|
|
|
|
|
} |
668
|
|
|
|
|
|
|
elsif( $whatami eq 'class' ) { |
669
|
3
|
|
|
|
|
12
|
$thing_name = qq[The class (or class-like) '$thing']; |
670
|
3
|
|
|
|
|
199
|
$name = "$thing_name isa '$class'"; |
671
|
3
|
|
|
|
|
152
|
$diag = "$thing_name isn't a '$class'"; |
672
|
|
|
|
|
|
|
} |
673
|
|
|
|
|
|
|
else { |
674
|
0
|
|
|
|
|
0
|
die; |
675
|
|
|
|
|
|
|
} |
676
|
|
|
|
|
|
|
|
677
|
33
|
|
|
|
|
61
|
my $ok; |
678
|
33
|
100
|
|
|
|
69
|
if($rslt) { |
679
|
23
|
|
|
|
|
81
|
$ok = $tb->ok( 1, $name ); |
680
|
|
|
|
|
|
|
} |
681
|
|
|
|
|
|
|
else { |
682
|
10
|
|
|
|
|
32
|
$ok = $tb->ok( 0, $name ); |
683
|
10
|
|
|
|
|
40
|
$tb->diag(" $diag\n"); |
684
|
|
|
|
|
|
|
} |
685
|
|
|
|
|
|
|
|
686
|
33
|
|
|
|
|
131
|
return $ok; |
687
|
|
|
|
|
|
|
} |
688
|
|
|
|
|
|
|
|
689
|
|
|
|
|
|
|
=item B<new_ok> |
690
|
|
|
|
|
|
|
|
691
|
|
|
|
|
|
|
my $obj = new_ok( $class ); |
692
|
|
|
|
|
|
|
my $obj = new_ok( $class => \@args ); |
693
|
|
|
|
|
|
|
my $obj = new_ok( $class => \@args, $object_name ); |
694
|
|
|
|
|
|
|
|
695
|
|
|
|
|
|
|
A convenience function which combines creating an object and calling |
696
|
|
|
|
|
|
|
C<isa_ok()> on that object. |
697
|
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
It is basically equivalent to: |
699
|
|
|
|
|
|
|
|
700
|
|
|
|
|
|
|
my $obj = $class->new(@args); |
701
|
|
|
|
|
|
|
isa_ok $obj, $class, $object_name; |
702
|
|
|
|
|
|
|
|
703
|
|
|
|
|
|
|
If @args is not given, an empty list will be used. |
704
|
|
|
|
|
|
|
|
705
|
|
|
|
|
|
|
This function only works on C<new()> and it assumes C<new()> will return |
706
|
|
|
|
|
|
|
just a single object which isa C<$class>. |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
=cut |
709
|
|
|
|
|
|
|
|
710
|
|
|
|
|
|
|
sub new_ok { |
711
|
11
|
|
|
11
|
1
|
130
|
my $tb = Test::More->builder; |
712
|
11
|
100
|
|
|
|
35
|
$tb->croak("new_ok() must be given at least a class") unless @_; |
713
|
|
|
|
|
|
|
|
714
|
10
|
|
|
|
|
23
|
my( $class, $args, $object_name ) = @_; |
715
|
|
|
|
|
|
|
|
716
|
10
|
|
100
|
|
|
42
|
$args ||= []; |
717
|
|
|
|
|
|
|
|
718
|
10
|
|
|
|
|
15
|
my $obj; |
719
|
10
|
|
|
10
|
|
67
|
my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } ); |
|
10
|
|
|
|
|
66
|
|
|
8
|
|
|
|
|
48
|
|
720
|
10
|
100
|
|
|
|
49
|
if($success) { |
721
|
8
|
|
|
|
|
18
|
local $Test::Builder::Level = $Test::Builder::Level + 1; |
722
|
8
|
|
|
|
|
25
|
isa_ok $obj, $class, $object_name; |
723
|
|
|
|
|
|
|
} |
724
|
|
|
|
|
|
|
else { |
725
|
2
|
100
|
|
|
|
6
|
$class = 'undef' if !defined $class; |
726
|
2
|
|
|
|
|
12
|
$tb->ok( 0, "$class->new() died" ); |
727
|
2
|
|
|
|
|
12
|
$tb->diag(" Error was: $error"); |
728
|
|
|
|
|
|
|
} |
729
|
|
|
|
|
|
|
|
730
|
10
|
|
|
|
|
43
|
return $obj; |
731
|
|
|
|
|
|
|
} |
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
=item B<subtest> |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
subtest $name => \&code, @args; |
736
|
|
|
|
|
|
|
|
737
|
|
|
|
|
|
|
C<subtest()> runs the &code as its own little test with its own plan and |
738
|
|
|
|
|
|
|
its own result. The main test counts this as a single test using the |
739
|
|
|
|
|
|
|
result of the whole subtest to determine if its ok or not ok. |
740
|
|
|
|
|
|
|
|
741
|
|
|
|
|
|
|
For example... |
742
|
|
|
|
|
|
|
|
743
|
|
|
|
|
|
|
use Test::More tests => 3; |
744
|
|
|
|
|
|
|
|
745
|
|
|
|
|
|
|
pass("First test"); |
746
|
|
|
|
|
|
|
|
747
|
|
|
|
|
|
|
subtest 'An example subtest' => sub { |
748
|
|
|
|
|
|
|
plan tests => 2; |
749
|
|
|
|
|
|
|
|
750
|
|
|
|
|
|
|
pass("This is a subtest"); |
751
|
|
|
|
|
|
|
pass("So is this"); |
752
|
|
|
|
|
|
|
}; |
753
|
|
|
|
|
|
|
|
754
|
|
|
|
|
|
|
pass("Third test"); |
755
|
|
|
|
|
|
|
|
756
|
|
|
|
|
|
|
This would produce. |
757
|
|
|
|
|
|
|
|
758
|
|
|
|
|
|
|
1..3 |
759
|
|
|
|
|
|
|
ok 1 - First test |
760
|
|
|
|
|
|
|
# Subtest: An example subtest |
761
|
|
|
|
|
|
|
1..2 |
762
|
|
|
|
|
|
|
ok 1 - This is a subtest |
763
|
|
|
|
|
|
|
ok 2 - So is this |
764
|
|
|
|
|
|
|
ok 2 - An example subtest |
765
|
|
|
|
|
|
|
ok 3 - Third test |
766
|
|
|
|
|
|
|
|
767
|
|
|
|
|
|
|
A subtest may call C<skip_all>. No tests will be run, but the subtest is |
768
|
|
|
|
|
|
|
considered a skip. |
769
|
|
|
|
|
|
|
|
770
|
|
|
|
|
|
|
subtest 'skippy' => sub { |
771
|
|
|
|
|
|
|
plan skip_all => 'cuz I said so'; |
772
|
|
|
|
|
|
|
pass('this test will never be run'); |
773
|
|
|
|
|
|
|
}; |
774
|
|
|
|
|
|
|
|
775
|
|
|
|
|
|
|
Returns true if the subtest passed, false otherwise. |
776
|
|
|
|
|
|
|
|
777
|
|
|
|
|
|
|
Due to how subtests work, you may omit a plan if you desire. This adds an |
778
|
|
|
|
|
|
|
implicit C<done_testing()> to the end of your subtest. The following two |
779
|
|
|
|
|
|
|
subtests are equivalent: |
780
|
|
|
|
|
|
|
|
781
|
|
|
|
|
|
|
subtest 'subtest with implicit done_testing()', sub { |
782
|
|
|
|
|
|
|
ok 1, 'subtests with an implicit done testing should work'; |
783
|
|
|
|
|
|
|
ok 1, '... and support more than one test'; |
784
|
|
|
|
|
|
|
ok 1, '... no matter how many tests are run'; |
785
|
|
|
|
|
|
|
}; |
786
|
|
|
|
|
|
|
|
787
|
|
|
|
|
|
|
subtest 'subtest with explicit done_testing()', sub { |
788
|
|
|
|
|
|
|
ok 1, 'subtests with an explicit done testing should work'; |
789
|
|
|
|
|
|
|
ok 1, '... and support more than one test'; |
790
|
|
|
|
|
|
|
ok 1, '... no matter how many tests are run'; |
791
|
|
|
|
|
|
|
done_testing(); |
792
|
|
|
|
|
|
|
}; |
793
|
|
|
|
|
|
|
|
794
|
|
|
|
|
|
|
Extra arguments given to C<subtest> are passed to the callback. For example: |
795
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
sub my_subtest { |
797
|
|
|
|
|
|
|
my $range = shift; |
798
|
|
|
|
|
|
|
... |
799
|
|
|
|
|
|
|
} |
800
|
|
|
|
|
|
|
|
801
|
|
|
|
|
|
|
for my $range (1, 10, 100, 1000) { |
802
|
|
|
|
|
|
|
subtest "testing range $range", \&my_subtest, $range; |
803
|
|
|
|
|
|
|
} |
804
|
|
|
|
|
|
|
|
805
|
|
|
|
|
|
|
=cut |
806
|
|
|
|
|
|
|
|
807
|
|
|
|
|
|
|
sub subtest { |
808
|
38
|
|
|
38
|
1
|
528
|
my $tb = Test::More->builder; |
809
|
38
|
|
|
|
|
180
|
return $tb->subtest(@_); |
810
|
|
|
|
|
|
|
} |
811
|
|
|
|
|
|
|
|
812
|
|
|
|
|
|
|
=item B<pass> |
813
|
|
|
|
|
|
|
|
814
|
|
|
|
|
|
|
=item B<fail> |
815
|
|
|
|
|
|
|
|
816
|
|
|
|
|
|
|
pass($test_name); |
817
|
|
|
|
|
|
|
fail($test_name); |
818
|
|
|
|
|
|
|
|
819
|
|
|
|
|
|
|
Sometimes you just want to say that the tests have passed. Usually |
820
|
|
|
|
|
|
|
the case is you've got some complicated condition that is difficult to |
821
|
|
|
|
|
|
|
wedge into an C<ok()>. In this case, you can simply use C<pass()> (to |
822
|
|
|
|
|
|
|
declare the test ok) or fail (for not ok). They are synonyms for |
823
|
|
|
|
|
|
|
C<ok(1)> and C<ok(0)>. |
824
|
|
|
|
|
|
|
|
825
|
|
|
|
|
|
|
Use these very, very, very sparingly. |
826
|
|
|
|
|
|
|
|
827
|
|
|
|
|
|
|
=cut |
828
|
|
|
|
|
|
|
|
829
|
|
|
|
|
|
|
sub pass (;$) { |
830
|
45
|
|
|
45
|
1
|
124993
|
my $tb = Test::More->builder; |
831
|
|
|
|
|
|
|
|
832
|
45
|
|
|
|
|
289
|
return $tb->ok( 1, @_ ); |
833
|
|
|
|
|
|
|
} |
834
|
|
|
|
|
|
|
|
835
|
|
|
|
|
|
|
sub fail (;$) { |
836
|
33
|
|
|
33
|
1
|
287
|
my $tb = Test::More->builder; |
837
|
|
|
|
|
|
|
|
838
|
33
|
|
|
|
|
117
|
return $tb->ok( 0, @_ ); |
839
|
|
|
|
|
|
|
} |
840
|
|
|
|
|
|
|
|
841
|
|
|
|
|
|
|
=back |
842
|
|
|
|
|
|
|
|
843
|
|
|
|
|
|
|
|
844
|
|
|
|
|
|
|
=head2 Module tests |
845
|
|
|
|
|
|
|
|
846
|
|
|
|
|
|
|
Sometimes you want to test if a module, or a list of modules, can |
847
|
|
|
|
|
|
|
successfully load. For example, you'll often want a first test which |
848
|
|
|
|
|
|
|
simply loads all the modules in the distribution to make sure they |
849
|
|
|
|
|
|
|
work before going on to do more complicated testing. |
850
|
|
|
|
|
|
|
|
851
|
|
|
|
|
|
|
For such purposes we have C<use_ok> and C<require_ok>. |
852
|
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
=over 4 |
854
|
|
|
|
|
|
|
|
855
|
|
|
|
|
|
|
=item B<require_ok> |
856
|
|
|
|
|
|
|
|
857
|
|
|
|
|
|
|
require_ok($module); |
858
|
|
|
|
|
|
|
require_ok($file); |
859
|
|
|
|
|
|
|
|
860
|
|
|
|
|
|
|
Tries to C<require> the given $module or $file. If it loads |
861
|
|
|
|
|
|
|
successfully, the test will pass. Otherwise it fails and displays the |
862
|
|
|
|
|
|
|
load error. |
863
|
|
|
|
|
|
|
|
864
|
|
|
|
|
|
|
C<require_ok> will guess whether the input is a module name or a |
865
|
|
|
|
|
|
|
filename. |
866
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
No exception will be thrown if the load fails. |
868
|
|
|
|
|
|
|
|
869
|
|
|
|
|
|
|
# require Some::Module |
870
|
|
|
|
|
|
|
require_ok "Some::Module"; |
871
|
|
|
|
|
|
|
|
872
|
|
|
|
|
|
|
# require "Some/File.pl"; |
873
|
|
|
|
|
|
|
require_ok "Some/File.pl"; |
874
|
|
|
|
|
|
|
|
875
|
|
|
|
|
|
|
# stop testing if any of your modules will not load |
876
|
|
|
|
|
|
|
for my $module (@module) { |
877
|
|
|
|
|
|
|
require_ok $module or BAIL_OUT "Can't load $module"; |
878
|
|
|
|
|
|
|
} |
879
|
|
|
|
|
|
|
|
880
|
|
|
|
|
|
|
=cut |
881
|
|
|
|
|
|
|
|
882
|
|
|
|
|
|
|
sub require_ok ($) { |
883
|
9
|
|
|
9
|
1
|
62
|
my($module) = shift; |
884
|
9
|
|
|
|
|
53
|
my $tb = Test::More->builder; |
885
|
|
|
|
|
|
|
|
886
|
9
|
|
|
|
|
25
|
my $pack = caller; |
887
|
|
|
|
|
|
|
|
888
|
|
|
|
|
|
|
# Try to determine if we've been given a module name or file. |
889
|
|
|
|
|
|
|
# Module names must be barewords, files not. |
890
|
9
|
100
|
|
|
|
44
|
$module = qq['$module'] unless _is_module_name($module); |
891
|
|
|
|
|
|
|
|
892
|
9
|
|
|
|
|
40
|
my $code = <<REQUIRE; |
893
|
|
|
|
|
|
|
package $pack; |
894
|
|
|
|
|
|
|
require $module; |
895
|
|
|
|
|
|
|
1; |
896
|
|
|
|
|
|
|
REQUIRE |
897
|
|
|
|
|
|
|
|
898
|
9
|
|
|
|
|
34
|
my( $eval_result, $eval_error ) = _eval($code); |
899
|
9
|
|
|
|
|
129
|
my $ok = $tb->ok( $eval_result, "require $module;" ); |
900
|
|
|
|
|
|
|
|
901
|
9
|
100
|
|
|
|
36
|
unless($ok) { |
902
|
2
|
|
|
|
|
6
|
chomp $eval_error; |
903
|
2
|
|
|
|
|
12
|
$tb->diag(<<DIAGNOSTIC); |
904
|
|
|
|
|
|
|
Tried to require '$module'. |
905
|
|
|
|
|
|
|
Error: $eval_error |
906
|
|
|
|
|
|
|
DIAGNOSTIC |
907
|
|
|
|
|
|
|
|
908
|
|
|
|
|
|
|
} |
909
|
|
|
|
|
|
|
|
910
|
9
|
|
|
|
|
1572
|
return $ok; |
911
|
|
|
|
|
|
|
} |
912
|
|
|
|
|
|
|
|
913
|
|
|
|
|
|
|
sub _is_module_name { |
914
|
13
|
|
|
13
|
|
37
|
my $module = shift; |
915
|
|
|
|
|
|
|
|
916
|
|
|
|
|
|
|
# Module names start with a letter. |
917
|
|
|
|
|
|
|
# End with an alphanumeric. |
918
|
|
|
|
|
|
|
# The rest is an alphanumeric or :: |
919
|
13
|
|
|
|
|
66
|
$module =~ s/\b::\b//g; |
920
|
|
|
|
|
|
|
|
921
|
13
|
100
|
|
|
|
100
|
return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0; |
922
|
|
|
|
|
|
|
} |
923
|
|
|
|
|
|
|
|
924
|
|
|
|
|
|
|
|
925
|
|
|
|
|
|
|
=item B<use_ok> |
926
|
|
|
|
|
|
|
|
927
|
|
|
|
|
|
|
BEGIN { use_ok($module); } |
928
|
|
|
|
|
|
|
BEGIN { use_ok($module, @imports); } |
929
|
|
|
|
|
|
|
|
930
|
|
|
|
|
|
|
Like C<require_ok>, but it will C<use> the $module in question and |
931
|
|
|
|
|
|
|
only loads modules, not files. |
932
|
|
|
|
|
|
|
|
933
|
|
|
|
|
|
|
If you just want to test a module can be loaded, use C<require_ok>. |
934
|
|
|
|
|
|
|
|
935
|
|
|
|
|
|
|
If you just want to load a module in a test, we recommend simply using |
936
|
|
|
|
|
|
|
C<use> directly. It will cause the test to stop. |
937
|
|
|
|
|
|
|
|
938
|
|
|
|
|
|
|
It's recommended that you run C<use_ok()> inside a BEGIN block so its |
939
|
|
|
|
|
|
|
functions are exported at compile-time and prototypes are properly |
940
|
|
|
|
|
|
|
honored. |
941
|
|
|
|
|
|
|
|
942
|
|
|
|
|
|
|
If @imports are given, they are passed through to the use. So this: |
943
|
|
|
|
|
|
|
|
944
|
|
|
|
|
|
|
BEGIN { use_ok('Some::Module', qw(foo bar)) } |
945
|
|
|
|
|
|
|
|
946
|
|
|
|
|
|
|
is like doing this: |
947
|
|
|
|
|
|
|
|
948
|
|
|
|
|
|
|
use Some::Module qw(foo bar); |
949
|
|
|
|
|
|
|
|
950
|
|
|
|
|
|
|
Version numbers can be checked like so: |
951
|
|
|
|
|
|
|
|
952
|
|
|
|
|
|
|
# Just like "use Some::Module 1.02" |
953
|
|
|
|
|
|
|
BEGIN { use_ok('Some::Module', 1.02) } |
954
|
|
|
|
|
|
|
|
955
|
|
|
|
|
|
|
Don't try to do this: |
956
|
|
|
|
|
|
|
|
957
|
|
|
|
|
|
|
BEGIN { |
958
|
|
|
|
|
|
|
use_ok('Some::Module'); |
959
|
|
|
|
|
|
|
|
960
|
|
|
|
|
|
|
...some code that depends on the use... |
961
|
|
|
|
|
|
|
...happening at compile time... |
962
|
|
|
|
|
|
|
} |
963
|
|
|
|
|
|
|
|
964
|
|
|
|
|
|
|
because the notion of "compile-time" is relative. Instead, you want: |
965
|
|
|
|
|
|
|
|
966
|
|
|
|
|
|
|
BEGIN { use_ok('Some::Module') } |
967
|
|
|
|
|
|
|
BEGIN { ...some code that depends on the use... } |
968
|
|
|
|
|
|
|
|
969
|
|
|
|
|
|
|
If you want the equivalent of C<use Foo ()>, use a module but not |
970
|
|
|
|
|
|
|
import anything, use C<require_ok>. |
971
|
|
|
|
|
|
|
|
972
|
|
|
|
|
|
|
BEGIN { require_ok "Foo" } |
973
|
|
|
|
|
|
|
|
974
|
|
|
|
|
|
|
=cut |
975
|
|
|
|
|
|
|
|
976
|
|
|
|
|
|
|
sub use_ok ($;@) { |
977
|
34
|
|
|
34
|
1
|
268
|
my( $module, @imports ) = @_; |
978
|
34
|
100
|
|
|
|
119
|
@imports = () unless @imports; |
979
|
34
|
|
|
|
|
233
|
my $tb = Test::More->builder; |
980
|
|
|
|
|
|
|
|
981
|
34
|
|
|
|
|
80
|
my %caller; |
982
|
34
|
|
|
|
|
381
|
@caller{qw/pack file line sub args want eval req strict warn/} = caller(0); |
983
|
|
|
|
|
|
|
|
984
|
34
|
|
|
|
|
138
|
my ($pack, $filename, $line, $warn) = @caller{qw/pack file line warn/}; |
985
|
34
|
|
|
|
|
116
|
$filename =~ y/\n\r/_/; # so it doesn't run off the "#line $line $f" line |
986
|
|
|
|
|
|
|
|
987
|
34
|
|
|
|
|
72
|
my $code; |
988
|
34
|
100
|
100
|
|
|
190
|
if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { |
989
|
|
|
|
|
|
|
# probably a version check. Perl needs to see the bare number |
990
|
|
|
|
|
|
|
# for it to work with non-Exporter based modules. |
991
|
3
|
|
|
|
|
18
|
$code = <<USE; |
992
|
|
|
|
|
|
|
package $pack; |
993
|
|
|
|
|
|
|
BEGIN { \${^WARNING_BITS} = \$args[-1] if defined \$args[-1] } |
994
|
|
|
|
|
|
|
#line $line $filename |
995
|
|
|
|
|
|
|
use $module $imports[0]; |
996
|
|
|
|
|
|
|
1; |
997
|
|
|
|
|
|
|
USE |
998
|
|
|
|
|
|
|
} |
999
|
|
|
|
|
|
|
else { |
1000
|
31
|
|
|
|
|
150
|
$code = <<USE; |
1001
|
|
|
|
|
|
|
package $pack; |
1002
|
|
|
|
|
|
|
BEGIN { \${^WARNING_BITS} = \$args[-1] if defined \$args[-1] } |
1003
|
|
|
|
|
|
|
#line $line $filename |
1004
|
|
|
|
|
|
|
use $module \@{\$args[0]}; |
1005
|
|
|
|
|
|
|
1; |
1006
|
|
|
|
|
|
|
USE |
1007
|
|
|
|
|
|
|
} |
1008
|
|
|
|
|
|
|
|
1009
|
34
|
|
|
|
|
128
|
my ($eval_result, $eval_error) = _eval($code, \@imports, $warn); |
1010
|
34
|
|
|
|
|
210
|
my $ok = $tb->ok( $eval_result, "use $module;" ); |
1011
|
|
|
|
|
|
|
|
1012
|
34
|
100
|
|
|
|
130
|
unless($ok) { |
1013
|
2
|
|
|
|
|
5
|
chomp $eval_error; |
1014
|
2
|
|
|
|
|
5
|
$@ =~ s{^BEGIN failed--compilation aborted at .*$} |
1015
|
2
|
|
|
|
|
16
|
{BEGIN failed--compilation aborted at $filename line $line.}m; |
1016
|
|
|
|
|
|
|
$tb->diag(<<DIAGNOSTIC); |
1017
|
|
|
|
|
|
|
Tried to use '$module'. |
1018
|
|
|
|
|
|
|
Error: $eval_error |
1019
|
|
|
|
|
|
|
DIAGNOSTIC |
1020
|
|
|
|
|
|
|
|
1021
|
|
|
|
|
|
|
} |
1022
|
34
|
|
|
|
|
26710
|
|
1023
|
|
|
|
|
|
|
return $ok; |
1024
|
|
|
|
|
|
|
} |
1025
|
|
|
|
|
|
|
|
1026
|
43
|
|
|
43
|
|
129
|
sub _eval { |
1027
|
|
|
|
|
|
|
my( $code, @args ) = @_; |
1028
|
|
|
|
|
|
|
|
1029
|
|
|
|
|
|
|
# Work around oddities surrounding resetting of $@ by immediately |
1030
|
43
|
|
|
|
|
101
|
# storing it. |
1031
|
|
|
|
|
|
|
my( $sigdie, $eval_result, $eval_error ); |
1032
|
43
|
|
|
|
|
80
|
{ |
|
43
|
|
|
|
|
269
|
|
1033
|
43
|
100
|
|
22
|
|
3802
|
local( $@, $!, $SIG{__DIE__} ); # isolate eval |
|
22
|
100
|
|
3
|
|
962
|
|
|
3
|
|
|
|
|
136
|
|
1034
|
43
|
|
|
|
|
4668
|
$eval_result = eval $code; ## no critic (BuiltinFunctions::ProhibitStringyEval) |
1035
|
43
|
|
100
|
|
|
522
|
$eval_error = $@; |
1036
|
|
|
|
|
|
|
$sigdie = $SIG{__DIE__} || undef; |
1037
|
|
|
|
|
|
|
} |
1038
|
43
|
100
|
|
|
|
158
|
# make sure that $code got a chance to set $SIG{__DIE__} |
1039
|
|
|
|
|
|
|
$SIG{__DIE__} = $sigdie if defined $sigdie; |
1040
|
43
|
|
|
|
|
169
|
|
1041
|
|
|
|
|
|
|
return( $eval_result, $eval_error ); |
1042
|
|
|
|
|
|
|
} |
1043
|
|
|
|
|
|
|
|
1044
|
|
|
|
|
|
|
|
1045
|
|
|
|
|
|
|
=back |
1046
|
|
|
|
|
|
|
|
1047
|
|
|
|
|
|
|
|
1048
|
|
|
|
|
|
|
=head2 Complex data structures |
1049
|
|
|
|
|
|
|
|
1050
|
|
|
|
|
|
|
Not everything is a simple eq check or regex. There are times you |
1051
|
|
|
|
|
|
|
need to see if two data structures are equivalent. For these |
1052
|
|
|
|
|
|
|
instances Test::More provides a handful of useful functions. |
1053
|
|
|
|
|
|
|
|
1054
|
|
|
|
|
|
|
B<NOTE> I'm not quite sure what will happen with filehandles. |
1055
|
|
|
|
|
|
|
|
1056
|
|
|
|
|
|
|
=over 4 |
1057
|
|
|
|
|
|
|
|
1058
|
|
|
|
|
|
|
=item B<is_deeply> |
1059
|
|
|
|
|
|
|
|
1060
|
|
|
|
|
|
|
is_deeply( $got, $expected, $test_name ); |
1061
|
|
|
|
|
|
|
|
1062
|
|
|
|
|
|
|
Similar to C<is()>, except that if $got and $expected are references, it |
1063
|
|
|
|
|
|
|
does a deep comparison walking each data structure to see if they are |
1064
|
|
|
|
|
|
|
equivalent. If the two structures are different, it will display the |
1065
|
|
|
|
|
|
|
place where they start differing. |
1066
|
|
|
|
|
|
|
|
1067
|
|
|
|
|
|
|
C<is_deeply()> compares the dereferenced values of references, the |
1068
|
|
|
|
|
|
|
references themselves (except for their type) are ignored. This means |
1069
|
|
|
|
|
|
|
aspects such as blessing and ties are not considered "different". |
1070
|
|
|
|
|
|
|
|
1071
|
|
|
|
|
|
|
C<is_deeply()> currently has very limited handling of function reference |
1072
|
|
|
|
|
|
|
and globs. It merely checks if they have the same referent. This may |
1073
|
|
|
|
|
|
|
improve in the future. |
1074
|
|
|
|
|
|
|
|
1075
|
|
|
|
|
|
|
L<Test::Differences> and L<Test::Deep> provide more in-depth functionality |
1076
|
|
|
|
|
|
|
along these lines. |
1077
|
|
|
|
|
|
|
|
1078
|
|
|
|
|
|
|
B<NOTE> is_deeply() has limitations when it comes to comparing strings and |
1079
|
|
|
|
|
|
|
refs: |
1080
|
|
|
|
|
|
|
|
1081
|
|
|
|
|
|
|
my $path = path('.'); |
1082
|
|
|
|
|
|
|
my $hash = {}; |
1083
|
|
|
|
|
|
|
is_deeply( $path, "$path" ); # ok |
1084
|
|
|
|
|
|
|
is_deeply( $hash, "$hash" ); # fail |
1085
|
|
|
|
|
|
|
|
1086
|
|
|
|
|
|
|
This happens because is_deeply will unoverload all arguments unconditionally. |
1087
|
|
|
|
|
|
|
It is probably best not to use is_deeply with overloading. For legacy reasons |
1088
|
|
|
|
|
|
|
this is not likely to ever be fixed. If you would like a much better tool for |
1089
|
|
|
|
|
|
|
this you should see L<Test2::Suite> Specifically L<Test2::Tools::Compare> has |
1090
|
|
|
|
|
|
|
an C<is()> function that works like C<is_deeply> with many improvements. |
1091
|
|
|
|
|
|
|
|
1092
|
|
|
|
|
|
|
=cut |
1093
|
|
|
|
|
|
|
|
1094
|
|
|
|
|
|
|
our( @Data_Stack, %Refs_Seen ); |
1095
|
|
|
|
|
|
|
my $DNE = bless [], 'Does::Not::Exist'; |
1096
|
|
|
|
|
|
|
|
1097
|
435
|
|
|
435
|
|
2135
|
sub _dne { |
1098
|
|
|
|
|
|
|
return ref $_[0] eq ref $DNE; |
1099
|
|
|
|
|
|
|
} |
1100
|
|
|
|
|
|
|
|
1101
|
|
|
|
|
|
|
## no critic (Subroutines::RequireArgUnpacking) |
1102
|
87
|
|
|
87
|
1
|
1132
|
sub is_deeply { |
1103
|
|
|
|
|
|
|
my $tb = Test::More->builder; |
1104
|
87
|
100
|
100
|
|
|
410
|
|
1105
|
3
|
|
|
|
|
7
|
unless( @_ == 2 or @_ == 3 ) { |
1106
|
|
|
|
|
|
|
my $msg = <<'WARNING'; |
1107
|
|
|
|
|
|
|
is_deeply() takes two or three args, you gave %d. |
1108
|
|
|
|
|
|
|
This usually means you passed an array or hash instead |
1109
|
|
|
|
|
|
|
of a reference to it |
1110
|
3
|
|
|
|
|
7
|
WARNING |
1111
|
|
|
|
|
|
|
chop $msg; # clip off newline so carp() will put in line/file |
1112
|
3
|
|
|
|
|
20
|
|
1113
|
|
|
|
|
|
|
_carp sprintf $msg, scalar @_; |
1114
|
3
|
|
|
|
|
25
|
|
1115
|
|
|
|
|
|
|
return $tb->ok(0); |
1116
|
|
|
|
|
|
|
} |
1117
|
84
|
|
|
|
|
200
|
|
1118
|
|
|
|
|
|
|
my( $got, $expected, $name ) = @_; |
1119
|
84
|
|
|
|
|
309
|
|
1120
|
|
|
|
|
|
|
$tb->_unoverload_str( \$expected, \$got ); |
1121
|
84
|
|
|
|
|
582
|
|
1122
|
84
|
100
|
100
|
|
|
515
|
my $ok; |
|
|
100
|
75
|
|
|
|
|
1123
|
6
|
|
|
|
|
22
|
if( !ref $got and !ref $expected ) { # neither is a reference |
1124
|
|
|
|
|
|
|
$ok = $tb->is_eq( $got, $expected, $name ); |
1125
|
|
|
|
|
|
|
} |
1126
|
4
|
|
|
|
|
14
|
elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't |
1127
|
4
|
|
|
|
|
19
|
$ok = $tb->ok( 0, $name ); |
1128
|
|
|
|
|
|
|
$tb->diag( _format_stack({ vals => [ $got, $expected ] }) ); |
1129
|
|
|
|
|
|
|
} |
1130
|
74
|
|
|
|
|
183
|
else { # both references |
1131
|
74
|
100
|
|
|
|
220
|
local @Data_Stack = (); |
1132
|
43
|
|
|
|
|
172
|
if( _deep_check( $got, $expected ) ) { |
1133
|
|
|
|
|
|
|
$ok = $tb->ok( 1, $name ); |
1134
|
|
|
|
|
|
|
} |
1135
|
31
|
|
|
|
|
85
|
else { |
1136
|
31
|
|
|
|
|
126
|
$ok = $tb->ok( 0, $name ); |
1137
|
|
|
|
|
|
|
$tb->diag( _format_stack(@Data_Stack) ); |
1138
|
|
|
|
|
|
|
} |
1139
|
|
|
|
|
|
|
} |
1140
|
84
|
|
|
|
|
821
|
|
1141
|
|
|
|
|
|
|
return $ok; |
1142
|
|
|
|
|
|
|
} |
1143
|
|
|
|
|
|
|
|
1144
|
35
|
|
|
35
|
|
74
|
sub _format_stack { |
1145
|
|
|
|
|
|
|
my(@Stack) = @_; |
1146
|
35
|
|
|
|
|
53
|
|
1147
|
35
|
|
|
|
|
50
|
my $var = '$FOO'; |
1148
|
35
|
|
|
|
|
62
|
my $did_arrow = 0; |
1149
|
49
|
|
100
|
|
|
120
|
foreach my $entry (@Stack) { |
1150
|
49
|
|
|
|
|
68
|
my $type = $entry->{type} || ''; |
1151
|
49
|
100
|
|
|
|
142
|
my $idx = $entry->{'idx'}; |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
1152
|
10
|
100
|
|
|
|
31
|
if( $type eq 'HASH' ) { |
1153
|
10
|
|
|
|
|
23
|
$var .= "->" unless $did_arrow++; |
1154
|
|
|
|
|
|
|
$var .= "{$idx}"; |
1155
|
|
|
|
|
|
|
} |
1156
|
15
|
50
|
|
|
|
41
|
elsif( $type eq 'ARRAY' ) { |
1157
|
15
|
|
|
|
|
40
|
$var .= "->" unless $did_arrow++; |
1158
|
|
|
|
|
|
|
$var .= "[$idx]"; |
1159
|
|
|
|
|
|
|
} |
1160
|
4
|
|
|
|
|
32
|
elsif( $type eq 'REF' ) { |
1161
|
|
|
|
|
|
|
$var = "\${$var}"; |
1162
|
|
|
|
|
|
|
} |
1163
|
|
|
|
|
|
|
} |
1164
|
35
|
|
|
|
|
51
|
|
|
35
|
|
|
|
|
105
|
|
1165
|
35
|
|
|
|
|
60
|
my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ]; |
1166
|
35
|
|
|
|
|
149
|
my @vars = (); |
1167
|
35
|
|
|
|
|
95
|
( $vars[0] = $var ) =~ s/\$FOO/ \$got/; |
1168
|
|
|
|
|
|
|
( $vars[1] = $var ) =~ s/\$FOO/\$expected/; |
1169
|
35
|
|
|
|
|
60
|
|
1170
|
35
|
|
|
|
|
88
|
my $out = "Structures begin differing at:\n"; |
1171
|
70
|
|
|
|
|
114
|
foreach my $idx ( 0 .. $#vals ) { |
1172
|
70
|
100
|
|
|
|
161
|
my $val = $vals[$idx]; |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
1173
|
|
|
|
|
|
|
$vals[$idx] |
1174
|
|
|
|
|
|
|
= !defined $val ? 'undef' |
1175
|
|
|
|
|
|
|
: _dne($val) ? "Does not exist" |
1176
|
|
|
|
|
|
|
: ref $val ? "$val" |
1177
|
|
|
|
|
|
|
: "'$val'"; |
1178
|
|
|
|
|
|
|
} |
1179
|
35
|
|
|
|
|
98
|
|
1180
|
35
|
|
|
|
|
84
|
$out .= "$vars[0] = $vals[0]\n"; |
1181
|
|
|
|
|
|
|
$out .= "$vars[1] = $vals[1]\n"; |
1182
|
35
|
|
|
|
|
211
|
|
1183
|
35
|
|
|
|
|
144
|
$out =~ s/^/ /msg; |
1184
|
|
|
|
|
|
|
return $out; |
1185
|
|
|
|
|
|
|
} |
1186
|
|
|
|
|
|
|
|
1187
|
544
|
|
|
544
|
|
759
|
sub _type { |
1188
|
|
|
|
|
|
|
my $thing = shift; |
1189
|
544
|
100
|
|
|
|
1008
|
|
1190
|
|
|
|
|
|
|
return '' if !ref $thing; |
1191
|
542
|
|
|
|
|
864
|
|
1192
|
1394
|
100
|
|
|
|
3486
|
for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE VSTRING)) { |
1193
|
|
|
|
|
|
|
return $type if UNIVERSAL::isa( $thing, $type ); |
1194
|
|
|
|
|
|
|
} |
1195
|
0
|
|
|
|
|
0
|
|
1196
|
|
|
|
|
|
|
return ''; |
1197
|
|
|
|
|
|
|
} |
1198
|
|
|
|
|
|
|
|
1199
|
|
|
|
|
|
|
=back |
1200
|
|
|
|
|
|
|
|
1201
|
|
|
|
|
|
|
|
1202
|
|
|
|
|
|
|
=head2 Diagnostics |
1203
|
|
|
|
|
|
|
|
1204
|
|
|
|
|
|
|
If you pick the right test function, you'll usually get a good idea of |
1205
|
|
|
|
|
|
|
what went wrong when it failed. But sometimes it doesn't work out |
1206
|
|
|
|
|
|
|
that way. So here we have ways for you to write your own diagnostic |
1207
|
|
|
|
|
|
|
messages which are safer than just C<print STDERR>. |
1208
|
|
|
|
|
|
|
|
1209
|
|
|
|
|
|
|
=over 4 |
1210
|
|
|
|
|
|
|
|
1211
|
|
|
|
|
|
|
=item B<diag> |
1212
|
|
|
|
|
|
|
|
1213
|
|
|
|
|
|
|
diag(@diagnostic_message); |
1214
|
|
|
|
|
|
|
|
1215
|
|
|
|
|
|
|
Prints a diagnostic message which is guaranteed not to interfere with |
1216
|
|
|
|
|
|
|
test output. Like C<print> @diagnostic_message is simply concatenated |
1217
|
|
|
|
|
|
|
together. |
1218
|
|
|
|
|
|
|
|
1219
|
|
|
|
|
|
|
Returns false, so as to preserve failure. |
1220
|
|
|
|
|
|
|
|
1221
|
|
|
|
|
|
|
Handy for this sort of thing: |
1222
|
|
|
|
|
|
|
|
1223
|
|
|
|
|
|
|
ok( grep(/foo/, @users), "There's a foo user" ) or |
1224
|
|
|
|
|
|
|
diag("Since there's no foo, check that /etc/bar is set up right"); |
1225
|
|
|
|
|
|
|
|
1226
|
|
|
|
|
|
|
which would produce: |
1227
|
|
|
|
|
|
|
|
1228
|
|
|
|
|
|
|
not ok 42 - There's a foo user |
1229
|
|
|
|
|
|
|
# Failed test 'There's a foo user' |
1230
|
|
|
|
|
|
|
# in foo.t at line 52. |
1231
|
|
|
|
|
|
|
# Since there's no foo, check that /etc/bar is set up right. |
1232
|
|
|
|
|
|
|
|
1233
|
|
|
|
|
|
|
You might remember C<ok() or diag()> with the mnemonic C<open() or |
1234
|
|
|
|
|
|
|
die()>. |
1235
|
|
|
|
|
|
|
|
1236
|
|
|
|
|
|
|
B<NOTE> The exact formatting of the diagnostic output is still |
1237
|
|
|
|
|
|
|
changing, but it is guaranteed that whatever you throw at it won't |
1238
|
|
|
|
|
|
|
interfere with the test. |
1239
|
|
|
|
|
|
|
|
1240
|
|
|
|
|
|
|
=item B<note> |
1241
|
|
|
|
|
|
|
|
1242
|
|
|
|
|
|
|
note(@diagnostic_message); |
1243
|
|
|
|
|
|
|
|
1244
|
|
|
|
|
|
|
Like C<diag()>, except the message will not be seen when the test is run |
1245
|
|
|
|
|
|
|
in a harness. It will only be visible in the verbose TAP stream. |
1246
|
|
|
|
|
|
|
|
1247
|
|
|
|
|
|
|
Handy for putting in notes which might be useful for debugging, but |
1248
|
|
|
|
|
|
|
don't indicate a problem. |
1249
|
|
|
|
|
|
|
|
1250
|
|
|
|
|
|
|
note("Tempfile is $tempfile"); |
1251
|
|
|
|
|
|
|
|
1252
|
|
|
|
|
|
|
=cut |
1253
|
|
|
|
|
|
|
|
1254
|
5
|
|
|
5
|
1
|
886
|
sub diag { |
1255
|
|
|
|
|
|
|
return Test::More->builder->diag(@_); |
1256
|
|
|
|
|
|
|
} |
1257
|
|
|
|
|
|
|
|
1258
|
11
|
|
|
11
|
1
|
78
|
sub note { |
1259
|
|
|
|
|
|
|
return Test::More->builder->note(@_); |
1260
|
|
|
|
|
|
|
} |
1261
|
|
|
|
|
|
|
|
1262
|
|
|
|
|
|
|
=item B<explain> |
1263
|
|
|
|
|
|
|
|
1264
|
|
|
|
|
|
|
my @dump = explain @diagnostic_message; |
1265
|
|
|
|
|
|
|
|
1266
|
|
|
|
|
|
|
Will dump the contents of any references in a human readable format. |
1267
|
|
|
|
|
|
|
Usually you want to pass this into C<note> or C<diag>. |
1268
|
|
|
|
|
|
|
|
1269
|
|
|
|
|
|
|
Handy for things like... |
1270
|
|
|
|
|
|
|
|
1271
|
|
|
|
|
|
|
is_deeply($have, $want) || diag explain $have; |
1272
|
|
|
|
|
|
|
|
1273
|
|
|
|
|
|
|
or |
1274
|
|
|
|
|
|
|
|
1275
|
|
|
|
|
|
|
note explain \%args; |
1276
|
|
|
|
|
|
|
Some::Class->method(%args); |
1277
|
|
|
|
|
|
|
|
1278
|
|
|
|
|
|
|
=cut |
1279
|
|
|
|
|
|
|
|
1280
|
5
|
|
|
5
|
1
|
35
|
sub explain { |
1281
|
|
|
|
|
|
|
return Test::More->builder->explain(@_); |
1282
|
|
|
|
|
|
|
} |
1283
|
|
|
|
|
|
|
|
1284
|
|
|
|
|
|
|
=back |
1285
|
|
|
|
|
|
|
|
1286
|
|
|
|
|
|
|
|
1287
|
|
|
|
|
|
|
=head2 Conditional tests |
1288
|
|
|
|
|
|
|
|
1289
|
|
|
|
|
|
|
Sometimes running a test under certain conditions will cause the |
1290
|
|
|
|
|
|
|
test script to die. A certain function or method isn't implemented |
1291
|
|
|
|
|
|
|
(such as C<fork()> on MacOS), some resource isn't available (like a |
1292
|
|
|
|
|
|
|
net connection) or a module isn't available. In these cases it's |
1293
|
|
|
|
|
|
|
necessary to skip tests, or declare that they are supposed to fail |
1294
|
|
|
|
|
|
|
but will work in the future (a todo test). |
1295
|
|
|
|
|
|
|
|
1296
|
|
|
|
|
|
|
For more details on the mechanics of skip and todo tests see |
1297
|
|
|
|
|
|
|
L<Test::Harness>. |
1298
|
|
|
|
|
|
|
|
1299
|
|
|
|
|
|
|
The way Test::More handles this is with a named block. Basically, a |
1300
|
|
|
|
|
|
|
block of tests which can be skipped over or made todo. It's best if I |
1301
|
|
|
|
|
|
|
just show you... |
1302
|
|
|
|
|
|
|
|
1303
|
|
|
|
|
|
|
=over 4 |
1304
|
|
|
|
|
|
|
|
1305
|
|
|
|
|
|
|
=item B<SKIP: BLOCK> |
1306
|
|
|
|
|
|
|
|
1307
|
|
|
|
|
|
|
SKIP: { |
1308
|
|
|
|
|
|
|
skip $why, $how_many if $condition; |
1309
|
|
|
|
|
|
|
|
1310
|
|
|
|
|
|
|
...normal testing code goes here... |
1311
|
|
|
|
|
|
|
} |
1312
|
|
|
|
|
|
|
|
1313
|
|
|
|
|
|
|
This declares a block of tests that might be skipped, $how_many tests |
1314
|
|
|
|
|
|
|
there are, $why and under what $condition to skip them. An example is |
1315
|
|
|
|
|
|
|
the easiest way to illustrate: |
1316
|
|
|
|
|
|
|
|
1317
|
|
|
|
|
|
|
SKIP: { |
1318
|
|
|
|
|
|
|
eval { require HTML::Lint }; |
1319
|
|
|
|
|
|
|
|
1320
|
|
|
|
|
|
|
skip "HTML::Lint not installed", 2 if $@; |
1321
|
|
|
|
|
|
|
|
1322
|
|
|
|
|
|
|
my $lint = new HTML::Lint; |
1323
|
|
|
|
|
|
|
isa_ok( $lint, "HTML::Lint" ); |
1324
|
|
|
|
|
|
|
|
1325
|
|
|
|
|
|
|
$lint->parse( $html ); |
1326
|
|
|
|
|
|
|
is( $lint->errors, 0, "No errors found in HTML" ); |
1327
|
|
|
|
|
|
|
} |
1328
|
|
|
|
|
|
|
|
1329
|
|
|
|
|
|
|
If the user does not have HTML::Lint installed, the whole block of |
1330
|
|
|
|
|
|
|
code I<won't be run at all>. Test::More will output special ok's |
1331
|
|
|
|
|
|
|
which Test::Harness interprets as skipped, but passing, tests. |
1332
|
|
|
|
|
|
|
|
1333
|
|
|
|
|
|
|
It's important that $how_many accurately reflects the number of tests |
1334
|
|
|
|
|
|
|
in the SKIP block so the # of tests run will match up with your plan. |
1335
|
|
|
|
|
|
|
If your plan is C<no_plan> $how_many is optional and will default to 1. |
1336
|
|
|
|
|
|
|
|
1337
|
|
|
|
|
|
|
It's perfectly safe to nest SKIP blocks. Each SKIP block must have |
1338
|
|
|
|
|
|
|
the label C<SKIP>, or Test::More can't work its magic. |
1339
|
|
|
|
|
|
|
|
1340
|
|
|
|
|
|
|
You don't skip tests which are failing because there's a bug in your |
1341
|
|
|
|
|
|
|
program, or for which you don't yet have code written. For that you |
1342
|
|
|
|
|
|
|
use TODO. Read on. |
1343
|
|
|
|
|
|
|
|
1344
|
|
|
|
|
|
|
=cut |
1345
|
|
|
|
|
|
|
|
1346
|
|
|
|
|
|
|
## no critic (Subroutines::RequireFinalReturn) |
1347
|
10
|
|
|
10
|
0
|
137
|
sub skip { |
1348
|
10
|
|
|
|
|
50
|
my( $why, $how_many ) = @_; |
1349
|
|
|
|
|
|
|
my $tb = Test::More->builder; |
1350
|
|
|
|
|
|
|
|
1351
|
|
|
|
|
|
|
# If the plan is set, and is static, then skip needs a count. If the plan |
1352
|
|
|
|
|
|
|
# is 'no_plan' we are fine. As well if plan is undefined then we are |
1353
|
10
|
100
|
|
|
|
31
|
# waiting for done_testing. |
1354
|
5
|
|
|
|
|
23
|
unless (defined $how_many) { |
1355
|
5
|
100
|
100
|
|
|
50
|
my $plan = $tb->has_plan; |
1356
|
|
|
|
|
|
|
_carp "skip() needs to know \$how_many tests are in the block" |
1357
|
5
|
|
|
|
|
24
|
if $plan && $plan =~ m/^\d+$/; |
1358
|
|
|
|
|
|
|
$how_many = 1; |
1359
|
|
|
|
|
|
|
} |
1360
|
10
|
100
|
66
|
|
|
79
|
|
1361
|
1
|
|
|
|
|
5
|
if( defined $how_many and $how_many =~ /\D/ ) { |
1362
|
|
|
|
|
|
|
_carp |
1363
|
1
|
|
|
|
|
8
|
"skip() was passed a non-numeric number of tests. Did you get the arguments backwards?"; |
1364
|
|
|
|
|
|
|
$how_many = 1; |
1365
|
|
|
|
|
|
|
} |
1366
|
10
|
|
|
|
|
37
|
|
1367
|
13
|
|
|
|
|
49
|
for( 1 .. $how_many ) { |
1368
|
|
|
|
|
|
|
$tb->skip($why); |
1369
|
|
|
|
|
|
|
} |
1370
|
127
|
|
|
128
|
|
1305
|
|
|
127
|
|
|
|
|
395
|
|
|
127
|
|
|
|
|
21889
|
|
1371
|
10
|
|
|
|
|
216
|
no warnings 'exiting'; |
1372
|
|
|
|
|
|
|
last SKIP; |
1373
|
|
|
|
|
|
|
} |
1374
|
|
|
|
|
|
|
|
1375
|
|
|
|
|
|
|
=item B<TODO: BLOCK> |
1376
|
|
|
|
|
|
|
|
1377
|
|
|
|
|
|
|
TODO: { |
1378
|
|
|
|
|
|
|
local $TODO = $why if $condition; |
1379
|
|
|
|
|
|
|
|
1380
|
|
|
|
|
|
|
...normal testing code goes here... |
1381
|
|
|
|
|
|
|
} |
1382
|
|
|
|
|
|
|
|
1383
|
|
|
|
|
|
|
Declares a block of tests you expect to fail and $why. Perhaps it's |
1384
|
|
|
|
|
|
|
because you haven't fixed a bug or haven't finished a new feature: |
1385
|
|
|
|
|
|
|
|
1386
|
|
|
|
|
|
|
TODO: { |
1387
|
|
|
|
|
|
|
local $TODO = "URI::Geller not finished"; |
1388
|
|
|
|
|
|
|
|
1389
|
|
|
|
|
|
|
my $card = "Eight of clubs"; |
1390
|
|
|
|
|
|
|
is( URI::Geller->your_card, $card, 'Is THIS your card?' ); |
1391
|
|
|
|
|
|
|
|
1392
|
|
|
|
|
|
|
my $spoon; |
1393
|
|
|
|
|
|
|
URI::Geller->bend_spoon; |
1394
|
|
|
|
|
|
|
is( $spoon, 'bent', "Spoon bending, that's original" ); |
1395
|
|
|
|
|
|
|
} |
1396
|
|
|
|
|
|
|
|
1397
|
|
|
|
|
|
|
With a todo block, the tests inside are expected to fail. Test::More |
1398
|
|
|
|
|
|
|
will run the tests normally, but print out special flags indicating |
1399
|
|
|
|
|
|
|
they are "todo". L<Test::Harness> will interpret failures as being ok. |
1400
|
|
|
|
|
|
|
Should anything succeed, it will report it as an unexpected success. |
1401
|
|
|
|
|
|
|
You then know the thing you had todo is done and can remove the |
1402
|
|
|
|
|
|
|
TODO flag. |
1403
|
|
|
|
|
|
|
|
1404
|
|
|
|
|
|
|
The nice part about todo tests, as opposed to simply commenting out a |
1405
|
|
|
|
|
|
|
block of tests, is that it is like having a programmatic todo list. You know |
1406
|
|
|
|
|
|
|
how much work is left to be done, you're aware of what bugs there are, |
1407
|
|
|
|
|
|
|
and you'll know immediately when they're fixed. |
1408
|
|
|
|
|
|
|
|
1409
|
|
|
|
|
|
|
Once a todo test starts succeeding, simply move it outside the block. |
1410
|
|
|
|
|
|
|
When the block is empty, delete it. |
1411
|
|
|
|
|
|
|
|
1412
|
|
|
|
|
|
|
|
1413
|
|
|
|
|
|
|
=item B<todo_skip> |
1414
|
|
|
|
|
|
|
|
1415
|
|
|
|
|
|
|
TODO: { |
1416
|
|
|
|
|
|
|
todo_skip $why, $how_many if $condition; |
1417
|
|
|
|
|
|
|
|
1418
|
|
|
|
|
|
|
...normal testing code... |
1419
|
|
|
|
|
|
|
} |
1420
|
|
|
|
|
|
|
|
1421
|
|
|
|
|
|
|
With todo tests, it's best to have the tests actually run. That way |
1422
|
|
|
|
|
|
|
you'll know when they start passing. Sometimes this isn't possible. |
1423
|
|
|
|
|
|
|
Often a failing test will cause the whole program to die or hang, even |
1424
|
|
|
|
|
|
|
inside an C<eval BLOCK> with and using C<alarm>. In these extreme |
1425
|
|
|
|
|
|
|
cases you have no choice but to skip over the broken tests entirely. |
1426
|
|
|
|
|
|
|
|
1427
|
|
|
|
|
|
|
The syntax and behavior is similar to a C<SKIP: BLOCK> except the |
1428
|
|
|
|
|
|
|
tests will be marked as failing but todo. L<Test::Harness> will |
1429
|
|
|
|
|
|
|
interpret them as passing. |
1430
|
|
|
|
|
|
|
|
1431
|
|
|
|
|
|
|
=cut |
1432
|
|
|
|
|
|
|
|
1433
|
3
|
|
|
3
|
1
|
40
|
sub todo_skip { |
1434
|
3
|
|
|
|
|
13
|
my( $why, $how_many ) = @_; |
1435
|
|
|
|
|
|
|
my $tb = Test::More->builder; |
1436
|
3
|
100
|
|
|
|
11
|
|
1437
|
|
|
|
|
|
|
unless( defined $how_many ) { |
1438
|
2
|
100
|
|
|
|
16
|
# $how_many can only be avoided when no_plan is in use. |
1439
|
|
|
|
|
|
|
_carp "todo_skip() needs to know \$how_many tests are in the block" |
1440
|
2
|
|
|
|
|
10
|
unless $tb->has_plan eq 'no_plan'; |
1441
|
|
|
|
|
|
|
$how_many = 1; |
1442
|
|
|
|
|
|
|
} |
1443
|
3
|
|
|
|
|
14
|
|
1444
|
4
|
|
|
|
|
15
|
for( 1 .. $how_many ) { |
1445
|
|
|
|
|
|
|
$tb->todo_skip($why); |
1446
|
|
|
|
|
|
|
} |
1447
|
127
|
|
|
128
|
|
1103
|
|
|
127
|
|
|
|
|
327
|
|
|
127
|
|
|
|
|
145449
|
|
1448
|
3
|
|
|
|
|
17
|
no warnings 'exiting'; |
1449
|
|
|
|
|
|
|
last TODO; |
1450
|
|
|
|
|
|
|
} |
1451
|
|
|
|
|
|
|
|
1452
|
|
|
|
|
|
|
=item When do I use SKIP vs. TODO? |
1453
|
|
|
|
|
|
|
|
1454
|
|
|
|
|
|
|
B<If it's something the user might not be able to do>, use SKIP. |
1455
|
|
|
|
|
|
|
This includes optional modules that aren't installed, running under |
1456
|
|
|
|
|
|
|
an OS that doesn't have some feature (like C<fork()> or symlinks), or maybe |
1457
|
|
|
|
|
|
|
you need an Internet connection and one isn't available. |
1458
|
|
|
|
|
|
|
|
1459
|
|
|
|
|
|
|
B<If it's something the programmer hasn't done yet>, use TODO. This |
1460
|
|
|
|
|
|
|
is for any code you haven't written yet, or bugs you have yet to fix, |
1461
|
|
|
|
|
|
|
but want to put tests in your testing script (always a good idea). |
1462
|
|
|
|
|
|
|
|
1463
|
|
|
|
|
|
|
|
1464
|
|
|
|
|
|
|
=back |
1465
|
|
|
|
|
|
|
|
1466
|
|
|
|
|
|
|
|
1467
|
|
|
|
|
|
|
=head2 Test control |
1468
|
|
|
|
|
|
|
|
1469
|
|
|
|
|
|
|
=over 4 |
1470
|
|
|
|
|
|
|
|
1471
|
|
|
|
|
|
|
=item B<BAIL_OUT> |
1472
|
|
|
|
|
|
|
|
1473
|
|
|
|
|
|
|
BAIL_OUT($reason); |
1474
|
|
|
|
|
|
|
|
1475
|
|
|
|
|
|
|
Indicates to the harness that things are going so badly all testing |
1476
|
|
|
|
|
|
|
should terminate. This includes the running of any additional test scripts. |
1477
|
|
|
|
|
|
|
|
1478
|
|
|
|
|
|
|
This is typically used when testing cannot continue such as a critical |
1479
|
|
|
|
|
|
|
module failing to compile or a necessary external utility not being |
1480
|
|
|
|
|
|
|
available such as a database connection failing. |
1481
|
|
|
|
|
|
|
|
1482
|
|
|
|
|
|
|
The test will exit with 255. |
1483
|
|
|
|
|
|
|
|
1484
|
|
|
|
|
|
|
For even better control look at L<Test::Most>. |
1485
|
|
|
|
|
|
|
|
1486
|
|
|
|
|
|
|
=cut |
1487
|
|
|
|
|
|
|
|
1488
|
2
|
|
|
2
|
1
|
18
|
sub BAIL_OUT { |
1489
|
2
|
|
|
|
|
9
|
my $reason = shift; |
1490
|
|
|
|
|
|
|
my $tb = Test::More->builder; |
1491
|
2
|
|
|
|
|
10
|
|
1492
|
|
|
|
|
|
|
$tb->BAIL_OUT($reason); |
1493
|
|
|
|
|
|
|
} |
1494
|
|
|
|
|
|
|
|
1495
|
|
|
|
|
|
|
=back |
1496
|
|
|
|
|
|
|
|
1497
|
|
|
|
|
|
|
|
1498
|
|
|
|
|
|
|
=head2 Discouraged comparison functions |
1499
|
|
|
|
|
|
|
|
1500
|
|
|
|
|
|
|
The use of the following functions is discouraged as they are not |
1501
|
|
|
|
|
|
|
actually testing functions and produce no diagnostics to help figure |
1502
|
|
|
|
|
|
|
out what went wrong. They were written before C<is_deeply()> existed |
1503
|
|
|
|
|
|
|
because I couldn't figure out how to display a useful diff of two |
1504
|
|
|
|
|
|
|
arbitrary data structures. |
1505
|
|
|
|
|
|
|
|
1506
|
|
|
|
|
|
|
These functions are usually used inside an C<ok()>. |
1507
|
|
|
|
|
|
|
|
1508
|
|
|
|
|
|
|
ok( eq_array(\@got, \@expected) ); |
1509
|
|
|
|
|
|
|
|
1510
|
|
|
|
|
|
|
C<is_deeply()> can do that better and with diagnostics. |
1511
|
|
|
|
|
|
|
|
1512
|
|
|
|
|
|
|
is_deeply( \@got, \@expected ); |
1513
|
|
|
|
|
|
|
|
1514
|
|
|
|
|
|
|
They may be deprecated in future versions. |
1515
|
|
|
|
|
|
|
|
1516
|
|
|
|
|
|
|
=over 4 |
1517
|
|
|
|
|
|
|
|
1518
|
|
|
|
|
|
|
=item B<eq_array> |
1519
|
|
|
|
|
|
|
|
1520
|
|
|
|
|
|
|
my $is_eq = eq_array(\@got, \@expected); |
1521
|
|
|
|
|
|
|
|
1522
|
|
|
|
|
|
|
Checks if two arrays are equivalent. This is a deep check, so |
1523
|
|
|
|
|
|
|
multi-level structures are handled correctly. |
1524
|
|
|
|
|
|
|
|
1525
|
|
|
|
|
|
|
=cut |
1526
|
|
|
|
|
|
|
|
1527
|
|
|
|
|
|
|
#'# |
1528
|
16
|
|
|
16
|
1
|
61
|
sub eq_array { |
1529
|
16
|
|
|
|
|
45
|
local @Data_Stack = (); |
1530
|
|
|
|
|
|
|
_deep_check(@_); |
1531
|
|
|
|
|
|
|
} |
1532
|
|
|
|
|
|
|
|
1533
|
70
|
|
|
70
|
|
150
|
sub _eq_array { |
1534
|
|
|
|
|
|
|
my( $a1, $a2 ) = @_; |
1535
|
70
|
50
|
|
|
|
206
|
|
1536
|
0
|
|
|
|
|
0
|
if( grep _type($_) ne 'ARRAY', $a1, $a2 ) { |
1537
|
0
|
|
|
|
|
0
|
warn "eq_array passed a non-array ref"; |
1538
|
|
|
|
|
|
|
return 0; |
1539
|
|
|
|
|
|
|
} |
1540
|
70
|
50
|
|
|
|
209
|
|
1541
|
|
|
|
|
|
|
return 1 if $a1 eq $a2; |
1542
|
70
|
|
|
|
|
153
|
|
1543
|
70
|
100
|
|
|
|
210
|
my $ok = 1; |
1544
|
70
|
|
|
|
|
198
|
my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; |
1545
|
162
|
100
|
|
|
|
377
|
for( 0 .. $max ) { |
1546
|
162
|
100
|
|
|
|
316
|
my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; |
1547
|
|
|
|
|
|
|
my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; |
1548
|
162
|
100
|
|
|
|
308
|
|
1549
|
|
|
|
|
|
|
next if _equal_nonrefs($e1, $e2); |
1550
|
62
|
|
|
|
|
290
|
|
1551
|
62
|
|
|
|
|
179
|
push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] }; |
1552
|
62
|
100
|
|
|
|
160
|
$ok = _deep_check( $e1, $e2 ); |
1553
|
|
|
|
|
|
|
pop @Data_Stack if $ok; |
1554
|
62
|
100
|
|
|
|
188
|
|
1555
|
|
|
|
|
|
|
last unless $ok; |
1556
|
|
|
|
|
|
|
} |
1557
|
70
|
|
|
|
|
182
|
|
1558
|
|
|
|
|
|
|
return $ok; |
1559
|
|
|
|
|
|
|
} |
1560
|
|
|
|
|
|
|
|
1561
|
271
|
|
|
271
|
|
499
|
sub _equal_nonrefs { |
1562
|
|
|
|
|
|
|
my( $e1, $e2 ) = @_; |
1563
|
271
|
100
|
100
|
|
|
894
|
|
1564
|
|
|
|
|
|
|
return if ref $e1 or ref $e2; |
1565
|
198
|
100
|
|
|
|
354
|
|
1566
|
183
|
100
|
100
|
|
|
850
|
if ( defined $e1 ) { |
1567
|
|
|
|
|
|
|
return 1 if defined $e2 and $e1 eq $e2; |
1568
|
|
|
|
|
|
|
} |
1569
|
15
|
100
|
|
|
|
58
|
else { |
1570
|
|
|
|
|
|
|
return 1 if !defined $e2; |
1571
|
|
|
|
|
|
|
} |
1572
|
15
|
|
|
|
|
34
|
|
1573
|
|
|
|
|
|
|
return; |
1574
|
|
|
|
|
|
|
} |
1575
|
|
|
|
|
|
|
|
1576
|
197
|
|
|
197
|
|
524
|
sub _deep_check { |
1577
|
197
|
|
|
|
|
725
|
my( $e1, $e2 ) = @_; |
1578
|
|
|
|
|
|
|
my $tb = Test::More->builder; |
1579
|
197
|
|
|
|
|
318
|
|
1580
|
|
|
|
|
|
|
my $ok = 0; |
1581
|
|
|
|
|
|
|
|
1582
|
|
|
|
|
|
|
# Effectively turn %Refs_Seen into a stack. This avoids picking up |
1583
|
|
|
|
|
|
|
# the same referenced used twice (such as [\$a, \$a]) to be considered |
1584
|
197
|
|
|
|
|
612
|
# circular. |
1585
|
|
|
|
|
|
|
local %Refs_Seen = %Refs_Seen; |
1586
|
|
|
|
|
|
|
|
1587
|
197
|
|
|
|
|
299
|
{ |
|
197
|
|
|
|
|
597
|
|
1588
|
|
|
|
|
|
|
$tb->_unoverload_str( \$e1, \$e2 ); |
1589
|
|
|
|
|
|
|
|
1590
|
197
|
|
100
|
|
|
1164
|
# Either they're both references or both not. |
1591
|
197
|
|
100
|
|
|
512
|
my $same_ref = !( !ref $e1 xor !ref $e2 ); |
1592
|
|
|
|
|
|
|
my $not_ref = ( !ref $e1 and !ref $e2 ); |
1593
|
197
|
100
|
75
|
|
|
1200
|
|
|
|
50
|
33
|
|
|
|
|
|
|
100
|
75
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
1594
|
10
|
|
|
|
|
21
|
if( defined $e1 xor defined $e2 ) { |
1595
|
|
|
|
|
|
|
$ok = 0; |
1596
|
|
|
|
|
|
|
} |
1597
|
|
|
|
|
|
|
elsif( !defined $e1 and !defined $e2 ) { |
1598
|
0
|
|
|
|
|
0
|
# Shortcut if they're both undefined. |
1599
|
|
|
|
|
|
|
$ok = 1; |
1600
|
|
|
|
|
|
|
} |
1601
|
7
|
|
|
|
|
12
|
elsif( _dne($e1) xor _dne($e2) ) { |
1602
|
|
|
|
|
|
|
$ok = 0; |
1603
|
|
|
|
|
|
|
} |
1604
|
15
|
|
|
|
|
57
|
elsif( $same_ref and( $e1 eq $e2 ) ) { |
1605
|
|
|
|
|
|
|
$ok = 1; |
1606
|
|
|
|
|
|
|
} |
1607
|
11
|
|
|
|
|
53
|
elsif($not_ref) { |
1608
|
11
|
|
|
|
|
24
|
push @Data_Stack, { type => '', vals => [ $e1, $e2 ] }; |
1609
|
|
|
|
|
|
|
$ok = 0; |
1610
|
|
|
|
|
|
|
} |
1611
|
154
|
100
|
|
|
|
393
|
else { |
1612
|
7
|
|
|
|
|
40
|
if( $Refs_Seen{$e1} ) { |
1613
|
|
|
|
|
|
|
return $Refs_Seen{$e1} eq $e2; |
1614
|
|
|
|
|
|
|
} |
1615
|
147
|
|
|
|
|
693
|
else { |
1616
|
|
|
|
|
|
|
$Refs_Seen{$e1} = "$e2"; |
1617
|
|
|
|
|
|
|
} |
1618
|
147
|
|
|
|
|
487
|
|
1619
|
147
|
100
|
|
|
|
282
|
my $type = _type($e1); |
1620
|
|
|
|
|
|
|
$type = 'DIFFERENT' unless _type($e2) eq $type; |
1621
|
147
|
100
|
|
|
|
566
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
1622
|
6
|
|
|
|
|
31
|
if( $type eq 'DIFFERENT' ) { |
1623
|
6
|
|
|
|
|
15
|
push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; |
1624
|
|
|
|
|
|
|
$ok = 0; |
1625
|
|
|
|
|
|
|
} |
1626
|
70
|
|
|
|
|
200
|
elsif( $type eq 'ARRAY' ) { |
1627
|
|
|
|
|
|
|
$ok = _eq_array( $e1, $e2 ); |
1628
|
|
|
|
|
|
|
} |
1629
|
55
|
|
|
|
|
165
|
elsif( $type eq 'HASH' ) { |
1630
|
|
|
|
|
|
|
$ok = _eq_hash( $e1, $e2 ); |
1631
|
|
|
|
|
|
|
} |
1632
|
8
|
|
|
|
|
36
|
elsif( $type eq 'REF' ) { |
1633
|
8
|
|
|
|
|
30
|
push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; |
1634
|
8
|
100
|
|
|
|
26
|
$ok = _deep_check( $$e1, $$e2 ); |
1635
|
|
|
|
|
|
|
pop @Data_Stack if $ok; |
1636
|
|
|
|
|
|
|
} |
1637
|
4
|
|
|
|
|
19
|
elsif( $type eq 'SCALAR' ) { |
1638
|
4
|
|
|
|
|
19
|
push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] }; |
1639
|
4
|
100
|
|
|
|
16
|
$ok = _deep_check( $$e1, $$e2 ); |
1640
|
|
|
|
|
|
|
pop @Data_Stack if $ok; |
1641
|
|
|
|
|
|
|
} |
1642
|
4
|
|
|
|
|
18
|
elsif($type) { |
1643
|
4
|
|
|
|
|
13
|
push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; |
1644
|
|
|
|
|
|
|
$ok = 0; |
1645
|
|
|
|
|
|
|
} |
1646
|
0
|
|
|
|
|
0
|
else { |
1647
|
|
|
|
|
|
|
_whoa( 1, "No type in _deep_check" ); |
1648
|
|
|
|
|
|
|
} |
1649
|
|
|
|
|
|
|
} |
1650
|
|
|
|
|
|
|
} |
1651
|
190
|
|
|
|
|
638
|
|
1652
|
|
|
|
|
|
|
return $ok; |
1653
|
|
|
|
|
|
|
} |
1654
|
|
|
|
|
|
|
|
1655
|
0
|
|
|
0
|
|
0
|
sub _whoa { |
1656
|
0
|
0
|
|
|
|
0
|
my( $check, $desc ) = @_; |
1657
|
0
|
|
|
|
|
0
|
if($check) { |
1658
|
|
|
|
|
|
|
die <<"WHOA"; |
1659
|
|
|
|
|
|
|
WHOA! $desc |
1660
|
|
|
|
|
|
|
This should never happen! Please contact the author immediately! |
1661
|
|
|
|
|
|
|
WHOA |
1662
|
|
|
|
|
|
|
} |
1663
|
|
|
|
|
|
|
} |
1664
|
|
|
|
|
|
|
|
1665
|
|
|
|
|
|
|
=item B<eq_hash> |
1666
|
|
|
|
|
|
|
|
1667
|
|
|
|
|
|
|
my $is_eq = eq_hash(\%got, \%expected); |
1668
|
|
|
|
|
|
|
|
1669
|
|
|
|
|
|
|
Determines if the two hashes contain the same keys and values. This |
1670
|
|
|
|
|
|
|
is a deep check. |
1671
|
|
|
|
|
|
|
|
1672
|
|
|
|
|
|
|
=cut |
1673
|
|
|
|
|
|
|
|
1674
|
7
|
|
|
7
|
1
|
22
|
sub eq_hash { |
1675
|
7
|
|
|
|
|
24
|
local @Data_Stack = (); |
1676
|
|
|
|
|
|
|
return _deep_check(@_); |
1677
|
|
|
|
|
|
|
} |
1678
|
|
|
|
|
|
|
|
1679
|
55
|
|
|
55
|
|
119
|
sub _eq_hash { |
1680
|
|
|
|
|
|
|
my( $a1, $a2 ) = @_; |
1681
|
55
|
50
|
|
|
|
183
|
|
1682
|
0
|
|
|
|
|
0
|
if( grep _type($_) ne 'HASH', $a1, $a2 ) { |
1683
|
0
|
|
|
|
|
0
|
warn "eq_hash passed a non-hash ref"; |
1684
|
|
|
|
|
|
|
return 0; |
1685
|
|
|
|
|
|
|
} |
1686
|
55
|
50
|
|
|
|
162
|
|
1687
|
|
|
|
|
|
|
return 1 if $a1 eq $a2; |
1688
|
55
|
|
|
|
|
91
|
|
1689
|
55
|
100
|
|
|
|
220
|
my $ok = 1; |
1690
|
55
|
|
|
|
|
147
|
my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; |
1691
|
109
|
100
|
|
|
|
302
|
foreach my $k ( keys %$bigger ) { |
1692
|
109
|
100
|
|
|
|
222
|
my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; |
1693
|
|
|
|
|
|
|
my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; |
1694
|
109
|
100
|
|
|
|
240
|
|
1695
|
|
|
|
|
|
|
next if _equal_nonrefs($e1, $e2); |
1696
|
26
|
|
|
|
|
125
|
|
1697
|
26
|
|
|
|
|
69
|
push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] }; |
1698
|
26
|
100
|
|
|
|
65
|
$ok = _deep_check( $e1, $e2 ); |
1699
|
|
|
|
|
|
|
pop @Data_Stack if $ok; |
1700
|
26
|
100
|
|
|
|
98
|
|
1701
|
|
|
|
|
|
|
last unless $ok; |
1702
|
|
|
|
|
|
|
} |
1703
|
55
|
|
|
|
|
160
|
|
1704
|
|
|
|
|
|
|
return $ok; |
1705
|
|
|
|
|
|
|
} |
1706
|
|
|
|
|
|
|
|
1707
|
|
|
|
|
|
|
=item B<eq_set> |
1708
|
|
|
|
|
|
|
|
1709
|
|
|
|
|
|
|
my $is_eq = eq_set(\@got, \@expected); |
1710
|
|
|
|
|
|
|
|
1711
|
|
|
|
|
|
|
Similar to C<eq_array()>, except the order of the elements is B<not> |
1712
|
|
|
|
|
|
|
important. This is a deep check, but the irrelevancy of order only |
1713
|
|
|
|
|
|
|
applies to the top level. |
1714
|
|
|
|
|
|
|
|
1715
|
|
|
|
|
|
|
ok( eq_set(\@got, \@expected) ); |
1716
|
|
|
|
|
|
|
|
1717
|
|
|
|
|
|
|
Is better written: |
1718
|
|
|
|
|
|
|
|
1719
|
|
|
|
|
|
|
is_deeply( [sort @got], [sort @expected] ); |
1720
|
|
|
|
|
|
|
|
1721
|
|
|
|
|
|
|
B<NOTE> By historical accident, this is not a true set comparison. |
1722
|
|
|
|
|
|
|
While the order of elements does not matter, duplicate elements do. |
1723
|
|
|
|
|
|
|
|
1724
|
|
|
|
|
|
|
B<NOTE> C<eq_set()> does not know how to deal with references at the top |
1725
|
|
|
|
|
|
|
level. The following is an example of a comparison which might not work: |
1726
|
|
|
|
|
|
|
|
1727
|
|
|
|
|
|
|
eq_set([\1, \2], [\2, \1]); |
1728
|
|
|
|
|
|
|
|
1729
|
|
|
|
|
|
|
L<Test::Deep> contains much better set comparison functions. |
1730
|
|
|
|
|
|
|
|
1731
|
|
|
|
|
|
|
=cut |
1732
|
|
|
|
|
|
|
|
1733
|
9
|
|
|
9
|
1
|
29
|
sub eq_set { |
1734
|
9
|
50
|
|
|
|
30
|
my( $a1, $a2 ) = @_; |
1735
|
|
|
|
|
|
|
return 0 unless @$a1 == @$a2; |
1736
|
127
|
|
|
128
|
|
1174
|
|
|
127
|
|
|
|
|
333
|
|
|
127
|
|
|
|
|
19993
|
|
1737
|
|
|
|
|
|
|
no warnings 'uninitialized'; |
1738
|
|
|
|
|
|
|
|
1739
|
|
|
|
|
|
|
# It really doesn't matter how we sort them, as long as both arrays are |
1740
|
|
|
|
|
|
|
# sorted with the same algorithm. |
1741
|
|
|
|
|
|
|
# |
1742
|
|
|
|
|
|
|
# Ensure that references are not accidentally treated the same as a |
1743
|
|
|
|
|
|
|
# string containing the reference. |
1744
|
|
|
|
|
|
|
# |
1745
|
|
|
|
|
|
|
# Have to inline the sort routine due to a threading/sort bug. |
1746
|
|
|
|
|
|
|
# See [rt.cpan.org 6782] |
1747
|
|
|
|
|
|
|
# |
1748
|
|
|
|
|
|
|
# I don't know how references would be sorted so we just don't sort |
1749
|
9
|
|
|
|
|
109
|
# them. This means eq_set doesn't really work with refs. |
1750
|
|
|
|
|
|
|
return eq_array( |
1751
|
|
|
|
|
|
|
[ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ], |
1752
|
|
|
|
|
|
|
[ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ], |
1753
|
|
|
|
|
|
|
); |
1754
|
|
|
|
|
|
|
} |
1755
|
|
|
|
|
|
|
|
1756
|
|
|
|
|
|
|
=back |
1757
|
|
|
|
|
|
|
|
1758
|
|
|
|
|
|
|
|
1759
|
|
|
|
|
|
|
=head2 Extending and Embedding Test::More |
1760
|
|
|
|
|
|
|
|
1761
|
|
|
|
|
|
|
Sometimes the Test::More interface isn't quite enough. Fortunately, |
1762
|
|
|
|
|
|
|
Test::More is built on top of L<Test::Builder> which provides a single, |
1763
|
|
|
|
|
|
|
unified backend for any test library to use. This means two test |
1764
|
|
|
|
|
|
|
libraries which both use <Test::Builder> B<can> be used together in the |
1765
|
|
|
|
|
|
|
same program>. |
1766
|
|
|
|
|
|
|
|
1767
|
|
|
|
|
|
|
If you simply want to do a little tweaking of how the tests behave, |
1768
|
|
|
|
|
|
|
you can access the underlying L<Test::Builder> object like so: |
1769
|
|
|
|
|
|
|
|
1770
|
|
|
|
|
|
|
=over 4 |
1771
|
|
|
|
|
|
|
|
1772
|
|
|
|
|
|
|
=item B<builder> |
1773
|
|
|
|
|
|
|
|
1774
|
|
|
|
|
|
|
my $test_builder = Test::More->builder; |
1775
|
|
|
|
|
|
|
|
1776
|
|
|
|
|
|
|
Returns the L<Test::Builder> object underlying Test::More for you to play |
1777
|
|
|
|
|
|
|
with. |
1778
|
|
|
|
|
|
|
|
1779
|
|
|
|
|
|
|
|
1780
|
|
|
|
|
|
|
=back |
1781
|
|
|
|
|
|
|
|
1782
|
|
|
|
|
|
|
|
1783
|
|
|
|
|
|
|
=head1 EXIT CODES |
1784
|
|
|
|
|
|
|
|
1785
|
|
|
|
|
|
|
If all your tests passed, L<Test::Builder> will exit with zero (which is |
1786
|
|
|
|
|
|
|
normal). If anything failed it will exit with how many failed. If |
1787
|
|
|
|
|
|
|
you run less (or more) tests than you planned, the missing (or extras) |
1788
|
|
|
|
|
|
|
will be considered failures. If no tests were ever run L<Test::Builder> |
1789
|
|
|
|
|
|
|
will throw a warning and exit with 255. If the test died, even after |
1790
|
|
|
|
|
|
|
having successfully completed all its tests, it will still be |
1791
|
|
|
|
|
|
|
considered a failure and will exit with 255. |
1792
|
|
|
|
|
|
|
|
1793
|
|
|
|
|
|
|
So the exit codes are... |
1794
|
|
|
|
|
|
|
|
1795
|
|
|
|
|
|
|
0 all tests successful |
1796
|
|
|
|
|
|
|
255 test died or all passed but wrong # of tests run |
1797
|
|
|
|
|
|
|
any other number how many failed (including missing or extras) |
1798
|
|
|
|
|
|
|
|
1799
|
|
|
|
|
|
|
If you fail more than 254 tests, it will be reported as 254. |
1800
|
|
|
|
|
|
|
|
1801
|
|
|
|
|
|
|
B<NOTE> This behavior may go away in future versions. |
1802
|
|
|
|
|
|
|
|
1803
|
|
|
|
|
|
|
|
1804
|
|
|
|
|
|
|
=head1 COMPATIBILITY |
1805
|
|
|
|
|
|
|
|
1806
|
|
|
|
|
|
|
Test::More works with Perls as old as 5.8.1. |
1807
|
|
|
|
|
|
|
|
1808
|
|
|
|
|
|
|
Thread support is not very reliable before 5.10.1, but that's |
1809
|
|
|
|
|
|
|
because threads are not very reliable before 5.10.1. |
1810
|
|
|
|
|
|
|
|
1811
|
|
|
|
|
|
|
Although Test::More has been a core module in versions of Perl since 5.6.2, Test::More has evolved since then, and not all of the features you're used to will be present in the shipped version of Test::More. If you are writing a module, don't forget to indicate in your package metadata the minimum version of Test::More that you require. For instance, if you want to use C<done_testing()> but want your test script to run on Perl 5.10.0, you will need to explicitly require Test::More > 0.88. |
1812
|
|
|
|
|
|
|
|
1813
|
|
|
|
|
|
|
Key feature milestones include: |
1814
|
|
|
|
|
|
|
|
1815
|
|
|
|
|
|
|
=over 4 |
1816
|
|
|
|
|
|
|
|
1817
|
|
|
|
|
|
|
=item subtests |
1818
|
|
|
|
|
|
|
|
1819
|
|
|
|
|
|
|
Subtests were released in Test::More 0.94, which came with Perl 5.12.0. Subtests did not implicitly call C<done_testing()> until 0.96; the first Perl with that fix was Perl 5.14.0 with 0.98. |
1820
|
|
|
|
|
|
|
|
1821
|
|
|
|
|
|
|
=item C<done_testing()> |
1822
|
|
|
|
|
|
|
|
1823
|
|
|
|
|
|
|
This was released in Test::More 0.88 and first shipped with Perl in 5.10.1 as part of Test::More 0.92. |
1824
|
|
|
|
|
|
|
|
1825
|
|
|
|
|
|
|
=item C<cmp_ok()> |
1826
|
|
|
|
|
|
|
|
1827
|
|
|
|
|
|
|
Although C<cmp_ok()> was introduced in 0.40, 0.86 fixed an important bug to make it safe for overloaded objects; the fixed first shipped with Perl in 5.10.1 as part of Test::More 0.92. |
1828
|
|
|
|
|
|
|
|
1829
|
|
|
|
|
|
|
=item C<new_ok()> C<note()> and C<explain()> |
1830
|
|
|
|
|
|
|
|
1831
|
|
|
|
|
|
|
These were was released in Test::More 0.82, and first shipped with Perl in 5.10.1 as part of Test::More 0.92. |
1832
|
|
|
|
|
|
|
|
1833
|
|
|
|
|
|
|
=back |
1834
|
|
|
|
|
|
|
|
1835
|
|
|
|
|
|
|
There is a full version history in the Changes file, and the Test::More versions included as core can be found using L<Module::CoreList>: |
1836
|
|
|
|
|
|
|
|
1837
|
|
|
|
|
|
|
$ corelist -a Test::More |
1838
|
|
|
|
|
|
|
|
1839
|
|
|
|
|
|
|
|
1840
|
|
|
|
|
|
|
=head1 CAVEATS and NOTES |
1841
|
|
|
|
|
|
|
|
1842
|
|
|
|
|
|
|
=over 4 |
1843
|
|
|
|
|
|
|
|
1844
|
|
|
|
|
|
|
=item utf8 / "Wide character in print" |
1845
|
|
|
|
|
|
|
|
1846
|
|
|
|
|
|
|
If you use utf8 or other non-ASCII characters with Test::More you |
1847
|
|
|
|
|
|
|
might get a "Wide character in print" warning. Using |
1848
|
|
|
|
|
|
|
C<< binmode STDOUT, ":utf8" >> will not fix it. |
1849
|
|
|
|
|
|
|
L<Test::Builder> (which powers |
1850
|
|
|
|
|
|
|
Test::More) duplicates STDOUT and STDERR. So any changes to them, |
1851
|
|
|
|
|
|
|
including changing their output disciplines, will not be seen by |
1852
|
|
|
|
|
|
|
Test::More. |
1853
|
|
|
|
|
|
|
|
1854
|
|
|
|
|
|
|
One work around is to apply encodings to STDOUT and STDERR as early |
1855
|
|
|
|
|
|
|
as possible and before Test::More (or any other Test module) loads. |
1856
|
|
|
|
|
|
|
|
1857
|
|
|
|
|
|
|
use open ':std', ':encoding(utf8)'; |
1858
|
|
|
|
|
|
|
use Test::More; |
1859
|
|
|
|
|
|
|
|
1860
|
|
|
|
|
|
|
A more direct work around is to change the filehandles used by |
1861
|
|
|
|
|
|
|
L<Test::Builder>. |
1862
|
|
|
|
|
|
|
|
1863
|
|
|
|
|
|
|
my $builder = Test::More->builder; |
1864
|
|
|
|
|
|
|
binmode $builder->output, ":encoding(utf8)"; |
1865
|
|
|
|
|
|
|
binmode $builder->failure_output, ":encoding(utf8)"; |
1866
|
|
|
|
|
|
|
binmode $builder->todo_output, ":encoding(utf8)"; |
1867
|
|
|
|
|
|
|
|
1868
|
|
|
|
|
|
|
|
1869
|
|
|
|
|
|
|
=item Overloaded objects |
1870
|
|
|
|
|
|
|
|
1871
|
|
|
|
|
|
|
String overloaded objects are compared B<as strings> (or in C<cmp_ok()>'s |
1872
|
|
|
|
|
|
|
case, strings or numbers as appropriate to the comparison op). This |
1873
|
|
|
|
|
|
|
prevents Test::More from piercing an object's interface allowing |
1874
|
|
|
|
|
|
|
better blackbox testing. So if a function starts returning overloaded |
1875
|
|
|
|
|
|
|
objects instead of bare strings your tests won't notice the |
1876
|
|
|
|
|
|
|
difference. This is good. |
1877
|
|
|
|
|
|
|
|
1878
|
|
|
|
|
|
|
However, it does mean that functions like C<is_deeply()> cannot be used to |
1879
|
|
|
|
|
|
|
test the internals of string overloaded objects. In this case I would |
1880
|
|
|
|
|
|
|
suggest L<Test::Deep> which contains more flexible testing functions for |
1881
|
|
|
|
|
|
|
complex data structures. |
1882
|
|
|
|
|
|
|
|
1883
|
|
|
|
|
|
|
|
1884
|
|
|
|
|
|
|
=item Threads |
1885
|
|
|
|
|
|
|
|
1886
|
|
|
|
|
|
|
Test::More will only be aware of threads if C<use threads> has been done |
1887
|
|
|
|
|
|
|
I<before> Test::More is loaded. This is ok: |
1888
|
|
|
|
|
|
|
|
1889
|
|
|
|
|
|
|
use threads; |
1890
|
|
|
|
|
|
|
use Test::More; |
1891
|
|
|
|
|
|
|
|
1892
|
|
|
|
|
|
|
This may cause problems: |
1893
|
|
|
|
|
|
|
|
1894
|
|
|
|
|
|
|
use Test::More |
1895
|
|
|
|
|
|
|
use threads; |
1896
|
|
|
|
|
|
|
|
1897
|
|
|
|
|
|
|
5.8.1 and above are supported. Anything below that has too many bugs. |
1898
|
|
|
|
|
|
|
|
1899
|
|
|
|
|
|
|
=back |
1900
|
|
|
|
|
|
|
|
1901
|
|
|
|
|
|
|
|
1902
|
|
|
|
|
|
|
=head1 HISTORY |
1903
|
|
|
|
|
|
|
|
1904
|
|
|
|
|
|
|
This is a case of convergent evolution with Joshua Pritikin's L<Test> |
1905
|
|
|
|
|
|
|
module. I was largely unaware of its existence when I'd first |
1906
|
|
|
|
|
|
|
written my own C<ok()> routines. This module exists because I can't |
1907
|
|
|
|
|
|
|
figure out how to easily wedge test names into Test's interface (along |
1908
|
|
|
|
|
|
|
with a few other problems). |
1909
|
|
|
|
|
|
|
|
1910
|
|
|
|
|
|
|
The goal here is to have a testing utility that's simple to learn, |
1911
|
|
|
|
|
|
|
quick to use and difficult to trip yourself up with while still |
1912
|
|
|
|
|
|
|
providing more flexibility than the existing Test.pm. As such, the |
1913
|
|
|
|
|
|
|
names of the most common routines are kept tiny, special cases and |
1914
|
|
|
|
|
|
|
magic side-effects are kept to a minimum. WYSIWYG. |
1915
|
|
|
|
|
|
|
|
1916
|
|
|
|
|
|
|
|
1917
|
|
|
|
|
|
|
=head1 SEE ALSO |
1918
|
|
|
|
|
|
|
|
1919
|
|
|
|
|
|
|
=head2 |
1920
|
|
|
|
|
|
|
|
1921
|
|
|
|
|
|
|
=head2 ALTERNATIVES |
1922
|
|
|
|
|
|
|
|
1923
|
|
|
|
|
|
|
L<Test2::Suite> is the most recent and modern set of tools for testing. |
1924
|
|
|
|
|
|
|
|
1925
|
|
|
|
|
|
|
L<Test::Simple> if all this confuses you and you just want to write |
1926
|
|
|
|
|
|
|
some tests. You can upgrade to Test::More later (it's forward |
1927
|
|
|
|
|
|
|
compatible). |
1928
|
|
|
|
|
|
|
|
1929
|
|
|
|
|
|
|
L<Test::Legacy> tests written with Test.pm, the original testing |
1930
|
|
|
|
|
|
|
module, do not play well with other testing libraries. Test::Legacy |
1931
|
|
|
|
|
|
|
emulates the Test.pm interface and does play well with others. |
1932
|
|
|
|
|
|
|
|
1933
|
|
|
|
|
|
|
=head2 ADDITIONAL LIBRARIES |
1934
|
|
|
|
|
|
|
|
1935
|
|
|
|
|
|
|
L<Test::Differences> for more ways to test complex data structures. |
1936
|
|
|
|
|
|
|
And it plays well with Test::More. |
1937
|
|
|
|
|
|
|
|
1938
|
|
|
|
|
|
|
L<Test::Class> is like xUnit but more perlish. |
1939
|
|
|
|
|
|
|
|
1940
|
|
|
|
|
|
|
L<Test::Deep> gives you more powerful complex data structure testing. |
1941
|
|
|
|
|
|
|
|
1942
|
|
|
|
|
|
|
L<Test::Inline> shows the idea of embedded testing. |
1943
|
|
|
|
|
|
|
|
1944
|
|
|
|
|
|
|
L<Mock::Quick> The ultimate mocking library. Easily spawn objects defined on |
1945
|
|
|
|
|
|
|
the fly. Can also override, block, or reimplement packages as needed. |
1946
|
|
|
|
|
|
|
|
1947
|
|
|
|
|
|
|
L<Test::FixtureBuilder> Quickly define fixture data for unit tests. |
1948
|
|
|
|
|
|
|
|
1949
|
|
|
|
|
|
|
=head2 OTHER COMPONENTS |
1950
|
|
|
|
|
|
|
|
1951
|
|
|
|
|
|
|
L<Test::Harness> is the test runner and output interpreter for Perl. |
1952
|
|
|
|
|
|
|
It's the thing that powers C<make test> and where the C<prove> utility |
1953
|
|
|
|
|
|
|
comes from. |
1954
|
|
|
|
|
|
|
|
1955
|
|
|
|
|
|
|
=head2 BUNDLES |
1956
|
|
|
|
|
|
|
|
1957
|
|
|
|
|
|
|
L<Test::Most> Most commonly needed test functions and features. |
1958
|
|
|
|
|
|
|
|
1959
|
|
|
|
|
|
|
=head1 AUTHORS |
1960
|
|
|
|
|
|
|
|
1961
|
|
|
|
|
|
|
Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration |
1962
|
|
|
|
|
|
|
from Joshua Pritikin's Test module and lots of help from Barrie |
1963
|
|
|
|
|
|
|
Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and |
1964
|
|
|
|
|
|
|
the perl-qa gang. |
1965
|
|
|
|
|
|
|
|
1966
|
|
|
|
|
|
|
=head1 MAINTAINERS |
1967
|
|
|
|
|
|
|
|
1968
|
|
|
|
|
|
|
=over 4 |
1969
|
|
|
|
|
|
|
|
1970
|
|
|
|
|
|
|
=item Chad Granum E<lt>exodist@cpan.orgE<gt> |
1971
|
|
|
|
|
|
|
|
1972
|
|
|
|
|
|
|
=back |
1973
|
|
|
|
|
|
|
|
1974
|
|
|
|
|
|
|
|
1975
|
|
|
|
|
|
|
=head1 BUGS |
1976
|
|
|
|
|
|
|
|
1977
|
|
|
|
|
|
|
See F<https://github.com/Test-More/test-more/issues> to report and view bugs. |
1978
|
|
|
|
|
|
|
|
1979
|
|
|
|
|
|
|
|
1980
|
|
|
|
|
|
|
=head1 SOURCE |
1981
|
|
|
|
|
|
|
|
1982
|
|
|
|
|
|
|
The source code repository for Test::More can be found at |
1983
|
|
|
|
|
|
|
F<http://github.com/Test-More/test-more/>. |
1984
|
|
|
|
|
|
|
|
1985
|
|
|
|
|
|
|
|
1986
|
|
|
|
|
|
|
=head1 COPYRIGHT |
1987
|
|
|
|
|
|
|
|
1988
|
|
|
|
|
|
|
Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. |
1989
|
|
|
|
|
|
|
|
1990
|
|
|
|
|
|
|
This program is free software; you can redistribute it and/or |
1991
|
|
|
|
|
|
|
modify it under the same terms as Perl itself. |
1992
|
|
|
|
|
|
|
|
1993
|
|
|
|
|
|
|
See F<http://www.perl.com/perl/misc/Artistic.html> |
1994
|
|
|
|
|
|
|
|
1995
|
|
|
|
|
|
|
=cut |
1996
|
|
|
|
|
|
|
|
1997
|
|
|
|
|
|
|
1; |