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