Commit | Line | Data |
3f2ec160 |
1 | package Test::More; |
2 | |
d020a79a |
3 | use 5.004; |
3f2ec160 |
4 | |
d020a79a |
5 | use strict; |
33459055 |
6 | use Test::Builder; |
3f2ec160 |
7 | |
33459055 |
8 | |
9 | # Can't use Carp because it might cause use_ok() to accidentally succeed |
10 | # even though the module being used forgot to use Carp. Yes, this |
11 | # actually happened. |
12 | sub _carp { |
13 | my($file, $line) = (caller(1))[1,2]; |
a9153838 |
14 | warn @_, " at $file line $line\n"; |
3f2ec160 |
15 | } |
16 | |
33459055 |
17 | |
18 | |
3f2ec160 |
19 | require Exporter; |
33459055 |
20 | use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); |
5143c659 |
21 | $VERSION = '0.60'; |
7483b81c |
22 | $VERSION = eval $VERSION; # make the alpha version come out as a number |
23 | |
3f2ec160 |
24 | @ISA = qw(Exporter); |
25 | @EXPORT = qw(ok use_ok require_ok |
a9153838 |
26 | is isnt like unlike is_deeply |
27 | cmp_ok |
28 | skip todo todo_skip |
3f2ec160 |
29 | pass fail |
de2dd90a |
30 | eq_array eq_hash eq_set |
d020a79a |
31 | $TODO |
32 | plan |
33 | can_ok isa_ok |
a9153838 |
34 | diag |
3f2ec160 |
35 | ); |
36 | |
33459055 |
37 | my $Test = Test::Builder->new; |
30e302f8 |
38 | my $Show_Diag = 1; |
3f2ec160 |
39 | |
3f2ec160 |
40 | |
41 | # 5.004's Exporter doesn't have export_to_level. |
42 | sub _export_to_level |
43 | { |
44 | my $pkg = shift; |
45 | my $level = shift; |
a9153838 |
46 | (undef) = shift; # redundant arg |
3f2ec160 |
47 | my $callpkg = caller($level); |
48 | $pkg->export($callpkg, @_); |
49 | } |
50 | |
51 | |
52 | =head1 NAME |
53 | |
54 | Test::More - yet another framework for writing test scripts |
55 | |
56 | =head1 SYNOPSIS |
57 | |
58 | use Test::More tests => $Num_Tests; |
59 | # or |
60 | use Test::More qw(no_plan); |
61 | # or |
d020a79a |
62 | use Test::More skip_all => $reason; |
3f2ec160 |
63 | |
64 | BEGIN { use_ok( 'Some::Module' ); } |
65 | require_ok( 'Some::Module' ); |
66 | |
67 | # Various ways to say "ok" |
68 | ok($this eq $that, $test_name); |
69 | |
70 | is ($this, $that, $test_name); |
71 | isnt($this, $that, $test_name); |
a9153838 |
72 | |
73 | # Rather than print STDERR "# here's what went wrong\n" |
74 | diag("here's what went wrong"); |
75 | |
76 | like ($this, qr/that/, $test_name); |
77 | unlike($this, qr/that/, $test_name); |
78 | |
79 | cmp_ok($this, '==', $that, $test_name); |
3f2ec160 |
80 | |
33459055 |
81 | is_deeply($complex_structure1, $complex_structure2, $test_name); |
82 | |
d020a79a |
83 | SKIP: { |
84 | skip $why, $how_many unless $have_some_feature; |
85 | |
3f2ec160 |
86 | ok( foo(), $test_name ); |
87 | is( foo(42), 23, $test_name ); |
d020a79a |
88 | }; |
89 | |
90 | TODO: { |
91 | local $TODO = $why; |
3f2ec160 |
92 | |
3f2ec160 |
93 | ok( foo(), $test_name ); |
94 | is( foo(42), 23, $test_name ); |
d020a79a |
95 | }; |
96 | |
97 | can_ok($module, @methods); |
98 | isa_ok($object, $class); |
3f2ec160 |
99 | |
100 | pass($test_name); |
101 | fail($test_name); |
102 | |
3f2ec160 |
103 | # UNIMPLEMENTED!!! |
104 | my @status = Test::More::status; |
105 | |
d020a79a |
106 | # UNIMPLEMENTED!!! |
107 | BAIL_OUT($why); |
108 | |
3f2ec160 |
109 | |
110 | =head1 DESCRIPTION |
111 | |
a9153838 |
112 | B<STOP!> If you're just getting started writing tests, have a look at |
d020a79a |
113 | Test::Simple first. This is a drop in replacement for Test::Simple |
114 | which you can switch to once you get the hang of basic testing. |
3f2ec160 |
115 | |
a9153838 |
116 | The purpose of this module is to provide a wide range of testing |
117 | utilities. Various ways to say "ok" with better diagnostics, |
118 | facilities to skip tests, test future features and compare complicated |
119 | data structures. While you can do almost anything with a simple |
120 | C<ok()> function, it doesn't provide good diagnostic output. |
3f2ec160 |
121 | |
122 | |
123 | =head2 I love it when a plan comes together |
124 | |
125 | Before anything else, you need a testing plan. This basically declares |
126 | how many tests your script is going to run to protect against premature |
127 | failure. |
128 | |
4bd4e70a |
129 | The preferred way to do this is to declare a plan when you C<use Test::More>. |
3f2ec160 |
130 | |
131 | use Test::More tests => $Num_Tests; |
132 | |
133 | There are rare cases when you will not know beforehand how many tests |
134 | your script is going to run. In this case, you can declare that you |
135 | have no plan. (Try to avoid using this as it weakens your test.) |
136 | |
137 | use Test::More qw(no_plan); |
138 | |
30e302f8 |
139 | B<NOTE>: using no_plan requires a Test::Harness upgrade else it will |
140 | think everything has failed. See L<BUGS and CAVEATS>) |
141 | |
3f2ec160 |
142 | In some cases, you'll want to completely skip an entire testing script. |
143 | |
d020a79a |
144 | use Test::More skip_all => $skip_reason; |
3f2ec160 |
145 | |
d020a79a |
146 | Your script will declare a skip with the reason why you skipped and |
147 | exit immediately with a zero (success). See L<Test::Harness> for |
148 | details. |
3f2ec160 |
149 | |
33459055 |
150 | If you want to control what functions Test::More will export, you |
151 | have to use the 'import' option. For example, to import everything |
152 | but 'fail', you'd do: |
153 | |
154 | use Test::More tests => 23, import => ['!fail']; |
155 | |
156 | Alternatively, you can use the plan() function. Useful for when you |
157 | have to calculate the number of tests. |
158 | |
159 | use Test::More; |
160 | plan tests => keys %Stuff * 3; |
161 | |
162 | or for deciding between running the tests at all: |
163 | |
164 | use Test::More; |
165 | if( $^O eq 'MacOS' ) { |
4bd4e70a |
166 | plan skip_all => 'Test irrelevant on MacOS'; |
33459055 |
167 | } |
168 | else { |
169 | plan tests => 42; |
170 | } |
171 | |
172 | =cut |
173 | |
174 | sub plan { |
175 | my(@plan) = @_; |
176 | |
30e302f8 |
177 | my $idx = 0; |
7483b81c |
178 | my @cleaned_plan; |
30e302f8 |
179 | while( $idx <= $#plan ) { |
7483b81c |
180 | my $item = $plan[$idx]; |
181 | |
182 | if( $item eq 'no_diag' ) { |
30e302f8 |
183 | $Show_Diag = 0; |
30e302f8 |
184 | } |
185 | else { |
7483b81c |
186 | push @cleaned_plan, $item; |
33459055 |
187 | } |
7483b81c |
188 | |
189 | $idx++; |
33459055 |
190 | } |
191 | |
30e302f8 |
192 | $Test->plan(@cleaned_plan); |
33459055 |
193 | } |
194 | |
195 | sub import { |
196 | my($class) = shift; |
7483b81c |
197 | |
198 | my $caller = caller; |
199 | |
200 | $Test->exported_to($caller); |
201 | |
202 | my $idx = 0; |
203 | my @plan; |
204 | my @imports; |
205 | while( $idx <= $#_ ) { |
206 | my $item = $_[$idx]; |
207 | |
208 | if( $item eq 'import' ) { |
209 | push @imports, @{$_[$idx+1]}; |
210 | $idx++; |
211 | } |
212 | else { |
213 | push @plan, $item; |
214 | } |
215 | |
216 | $idx++; |
217 | } |
218 | |
219 | plan(@plan); |
220 | |
221 | __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); |
33459055 |
222 | } |
223 | |
3f2ec160 |
224 | |
225 | =head2 Test names |
226 | |
227 | By convention, each test is assigned a number in order. This is |
6686786d |
228 | largely done automatically for you. However, it's often very useful to |
3f2ec160 |
229 | assign a name to each test. Which would you rather see: |
230 | |
231 | ok 4 |
232 | not ok 5 |
233 | ok 6 |
234 | |
235 | or |
236 | |
237 | ok 4 - basic multi-variable |
238 | not ok 5 - simple exponential |
239 | ok 6 - force == mass * acceleration |
240 | |
241 | The later gives you some idea of what failed. It also makes it easier |
242 | to find the test in your script, simply search for "simple |
243 | exponential". |
244 | |
6686786d |
245 | All test functions take a name argument. It's optional, but highly |
3f2ec160 |
246 | suggested that you use it. |
247 | |
248 | |
249 | =head2 I'm ok, you're not ok. |
250 | |
251 | The basic purpose of this module is to print out either "ok #" or "not |
252 | ok #" depending on if a given test succeeded or failed. Everything |
253 | else is just gravy. |
254 | |
255 | All of the following print "ok" or "not ok" depending on if the test |
256 | succeeded or failed. They all also return true or false, |
257 | respectively. |
258 | |
259 | =over 4 |
260 | |
261 | =item B<ok> |
262 | |
263 | ok($this eq $that, $test_name); |
264 | |
265 | This simply evaluates any expression (C<$this eq $that> is just a |
266 | simple example) and uses that to determine if the test succeeded or |
267 | failed. A true expression passes, a false one fails. Very simple. |
268 | |
269 | For example: |
270 | |
271 | ok( $exp{9} == 81, 'simple exponential' ); |
272 | ok( Film->can('db_Main'), 'set_db()' ); |
273 | ok( $p->tests == 4, 'saw tests' ); |
274 | ok( !grep !defined $_, @items, 'items populated' ); |
275 | |
276 | (Mnemonic: "This is ok.") |
277 | |
278 | $test_name is a very short description of the test that will be printed |
279 | out. It makes it very easy to find a test in your script when it fails |
280 | and gives others an idea of your intentions. $test_name is optional, |
281 | but we B<very> strongly encourage its use. |
282 | |
283 | Should an ok() fail, it will produce some diagnostics: |
284 | |
285 | not ok 18 - sufficient mucus |
286 | # Failed test 18 (foo.t at line 42) |
287 | |
288 | This is actually Test::Simple's ok() routine. |
289 | |
290 | =cut |
291 | |
33459055 |
292 | sub ok ($;$) { |
293 | my($test, $name) = @_; |
294 | $Test->ok($test, $name); |
295 | } |
3f2ec160 |
296 | |
297 | =item B<is> |
298 | |
299 | =item B<isnt> |
300 | |
301 | is ( $this, $that, $test_name ); |
302 | isnt( $this, $that, $test_name ); |
303 | |
d020a79a |
304 | Similar to ok(), is() and isnt() compare their two arguments |
305 | with C<eq> and C<ne> respectively and use the result of that to |
306 | determine if the test succeeded or failed. So these: |
3f2ec160 |
307 | |
308 | # Is the ultimate answer 42? |
309 | is( ultimate_answer(), 42, "Meaning of Life" ); |
310 | |
311 | # $foo isn't empty |
312 | isnt( $foo, '', "Got some foo" ); |
313 | |
314 | are similar to these: |
315 | |
316 | ok( ultimate_answer() eq 42, "Meaning of Life" ); |
317 | ok( $foo ne '', "Got some foo" ); |
318 | |
319 | (Mnemonic: "This is that." "This isn't that.") |
320 | |
321 | So why use these? They produce better diagnostics on failure. ok() |
322 | cannot know what you are testing for (beyond the name), but is() and |
323 | isnt() know what the test was and why it failed. For example this |
d020a79a |
324 | test: |
3f2ec160 |
325 | |
326 | my $foo = 'waffle'; my $bar = 'yarblokos'; |
327 | is( $foo, $bar, 'Is foo the same as bar?' ); |
328 | |
329 | Will produce something like this: |
330 | |
331 | not ok 17 - Is foo the same as bar? |
60ffb308 |
332 | # Failed test (foo.t at line 139) |
3f2ec160 |
333 | # got: 'waffle' |
334 | # expected: 'yarblokos' |
335 | |
336 | So you can figure out what went wrong without rerunning the test. |
337 | |
338 | You are encouraged to use is() and isnt() over ok() where possible, |
339 | however do not be tempted to use them to find out if something is |
340 | true or false! |
341 | |
30e302f8 |
342 | # XXX BAD! |
343 | is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' ); |
3f2ec160 |
344 | |
30e302f8 |
345 | This does not check if C<exists $brooklyn{tree}> is true, it checks if |
3f2ec160 |
346 | it returns 1. Very different. Similar caveats exist for false and 0. |
347 | In these cases, use ok(). |
348 | |
30e302f8 |
349 | ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' ); |
3f2ec160 |
350 | |
d020a79a |
351 | For those grammatical pedants out there, there's an C<isn't()> |
352 | function which is an alias of isnt(). |
3f2ec160 |
353 | |
354 | =cut |
355 | |
356 | sub is ($$;$) { |
33459055 |
357 | $Test->is_eq(@_); |
3f2ec160 |
358 | } |
359 | |
360 | sub isnt ($$;$) { |
a9153838 |
361 | $Test->isnt_eq(@_); |
3f2ec160 |
362 | } |
363 | |
364 | *isn't = \&isnt; |
365 | |
366 | |
367 | =item B<like> |
368 | |
369 | like( $this, qr/that/, $test_name ); |
370 | |
371 | Similar to ok(), like() matches $this against the regex C<qr/that/>. |
372 | |
373 | So this: |
374 | |
375 | like($this, qr/that/, 'this is like that'); |
376 | |
377 | is similar to: |
378 | |
379 | ok( $this =~ /that/, 'this is like that'); |
380 | |
381 | (Mnemonic "This is like that".) |
382 | |
383 | The second argument is a regular expression. It may be given as a |
4bd4e70a |
384 | regex reference (i.e. C<qr//>) or (for better compatibility with older |
3f2ec160 |
385 | perls) as a string that looks like a regex (alternative delimiters are |
386 | currently not supported): |
387 | |
388 | like( $this, '/that/', 'this is like that' ); |
389 | |
390 | Regex options may be placed on the end (C<'/that/i'>). |
391 | |
392 | Its advantages over ok() are similar to that of is() and isnt(). Better |
393 | diagnostics on failure. |
394 | |
395 | =cut |
396 | |
397 | sub like ($$;$) { |
33459055 |
398 | $Test->like(@_); |
3f2ec160 |
399 | } |
400 | |
a9153838 |
401 | |
402 | =item B<unlike> |
403 | |
404 | unlike( $this, qr/that/, $test_name ); |
405 | |
406 | Works exactly as like(), only it checks if $this B<does not> match the |
407 | given pattern. |
408 | |
409 | =cut |
410 | |
30e302f8 |
411 | sub unlike ($$;$) { |
a9153838 |
412 | $Test->unlike(@_); |
413 | } |
414 | |
415 | |
416 | =item B<cmp_ok> |
417 | |
418 | cmp_ok( $this, $op, $that, $test_name ); |
419 | |
420 | Halfway between ok() and is() lies cmp_ok(). This allows you to |
421 | compare two arguments using any binary perl operator. |
422 | |
423 | # ok( $this eq $that ); |
424 | cmp_ok( $this, 'eq', $that, 'this eq that' ); |
425 | |
426 | # ok( $this == $that ); |
427 | cmp_ok( $this, '==', $that, 'this == that' ); |
428 | |
429 | # ok( $this && $that ); |
30e302f8 |
430 | cmp_ok( $this, '&&', $that, 'this && that' ); |
a9153838 |
431 | ...etc... |
432 | |
433 | Its advantage over ok() is when the test fails you'll know what $this |
434 | and $that were: |
435 | |
436 | not ok 1 |
437 | # Failed test (foo.t at line 12) |
438 | # '23' |
439 | # && |
440 | # undef |
441 | |
6686786d |
442 | It's also useful in those cases where you are comparing numbers and |
a9153838 |
443 | is()'s use of C<eq> will interfere: |
444 | |
445 | cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); |
446 | |
447 | =cut |
448 | |
449 | sub cmp_ok($$$;$) { |
450 | $Test->cmp_ok(@_); |
451 | } |
452 | |
453 | |
d020a79a |
454 | =item B<can_ok> |
455 | |
456 | can_ok($module, @methods); |
457 | can_ok($object, @methods); |
458 | |
459 | Checks to make sure the $module or $object can do these @methods |
460 | (works with functions, too). |
461 | |
462 | can_ok('Foo', qw(this that whatever)); |
463 | |
464 | is almost exactly like saying: |
465 | |
466 | ok( Foo->can('this') && |
467 | Foo->can('that') && |
468 | Foo->can('whatever') |
469 | ); |
470 | |
471 | only without all the typing and with a better interface. Handy for |
472 | quickly testing an interface. |
473 | |
a9153838 |
474 | No matter how many @methods you check, a single can_ok() call counts |
475 | as one test. If you desire otherwise, use: |
476 | |
477 | foreach my $meth (@methods) { |
478 | can_ok('Foo', $meth); |
479 | } |
480 | |
d020a79a |
481 | =cut |
482 | |
483 | sub can_ok ($@) { |
484 | my($proto, @methods) = @_; |
89c1e84a |
485 | my $class = ref $proto || $proto; |
d020a79a |
486 | |
a9153838 |
487 | unless( @methods ) { |
488 | my $ok = $Test->ok( 0, "$class->can(...)" ); |
489 | $Test->diag(' can_ok() called with no methods'); |
490 | return $ok; |
491 | } |
492 | |
d020a79a |
493 | my @nok = (); |
494 | foreach my $method (@methods) { |
a9153838 |
495 | local($!, $@); # don't interfere with caller's $@ |
496 | # eval sometimes resets $! |
89c1e84a |
497 | eval { $proto->can($method) } || push @nok, $method; |
d020a79a |
498 | } |
499 | |
500 | my $name; |
6686786d |
501 | $name = @methods == 1 ? "$class->can('$methods[0]')" |
d020a79a |
502 | : "$class->can(...)"; |
503 | |
33459055 |
504 | my $ok = $Test->ok( !@nok, $name ); |
d020a79a |
505 | |
a9153838 |
506 | $Test->diag(map " $class->can('$_') failed\n", @nok); |
d020a79a |
507 | |
33459055 |
508 | return $ok; |
d020a79a |
509 | } |
510 | |
511 | =item B<isa_ok> |
512 | |
33459055 |
513 | isa_ok($object, $class, $object_name); |
a9153838 |
514 | isa_ok($ref, $type, $ref_name); |
d020a79a |
515 | |
30e302f8 |
516 | Checks to see if the given C<< $object->isa($class) >>. Also checks to make |
d020a79a |
517 | sure the object was defined in the first place. Handy for this sort |
518 | of thing: |
519 | |
520 | my $obj = Some::Module->new; |
521 | isa_ok( $obj, 'Some::Module' ); |
522 | |
523 | where you'd otherwise have to write |
524 | |
525 | my $obj = Some::Module->new; |
526 | ok( defined $obj && $obj->isa('Some::Module') ); |
527 | |
528 | to safeguard against your test script blowing up. |
529 | |
a9153838 |
530 | It works on references, too: |
531 | |
532 | isa_ok( $array_ref, 'ARRAY' ); |
533 | |
33459055 |
534 | The diagnostics of this test normally just refer to 'the object'. If |
535 | you'd like them to be more specific, you can supply an $object_name |
536 | (for example 'Test customer'). |
537 | |
d020a79a |
538 | =cut |
539 | |
33459055 |
540 | sub isa_ok ($$;$) { |
541 | my($object, $class, $obj_name) = @_; |
d020a79a |
542 | |
543 | my $diag; |
33459055 |
544 | $obj_name = 'The object' unless defined $obj_name; |
545 | my $name = "$obj_name isa $class"; |
d020a79a |
546 | if( !defined $object ) { |
33459055 |
547 | $diag = "$obj_name isn't defined"; |
d020a79a |
548 | } |
549 | elsif( !ref $object ) { |
33459055 |
550 | $diag = "$obj_name isn't a reference"; |
d020a79a |
551 | } |
a9153838 |
552 | else { |
553 | # We can't use UNIVERSAL::isa because we want to honor isa() overrides |
554 | local($@, $!); # eval sometimes resets $! |
555 | my $rslt = eval { $object->isa($class) }; |
556 | if( $@ ) { |
557 | if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) { |
558 | if( !UNIVERSAL::isa($object, $class) ) { |
559 | my $ref = ref $object; |
6686786d |
560 | $diag = "$obj_name isn't a '$class' it's a '$ref'"; |
a9153838 |
561 | } |
562 | } else { |
563 | die <<WHOA; |
564 | WHOA! I tried to call ->isa on your object and got some weird error. |
565 | This should never happen. Please contact the author immediately. |
566 | Here's the error. |
567 | $@ |
568 | WHOA |
569 | } |
570 | } |
571 | elsif( !$rslt ) { |
572 | my $ref = ref $object; |
6686786d |
573 | $diag = "$obj_name isn't a '$class' it's a '$ref'"; |
a9153838 |
574 | } |
d020a79a |
575 | } |
a9153838 |
576 | |
577 | |
d020a79a |
578 | |
33459055 |
579 | my $ok; |
d020a79a |
580 | if( $diag ) { |
33459055 |
581 | $ok = $Test->ok( 0, $name ); |
a9153838 |
582 | $Test->diag(" $diag\n"); |
d020a79a |
583 | } |
584 | else { |
33459055 |
585 | $ok = $Test->ok( 1, $name ); |
d020a79a |
586 | } |
33459055 |
587 | |
588 | return $ok; |
d020a79a |
589 | } |
590 | |
591 | |
3f2ec160 |
592 | =item B<pass> |
593 | |
594 | =item B<fail> |
595 | |
596 | pass($test_name); |
597 | fail($test_name); |
598 | |
599 | Sometimes you just want to say that the tests have passed. Usually |
600 | the case is you've got some complicated condition that is difficult to |
601 | wedge into an ok(). In this case, you can simply use pass() (to |
602 | declare the test ok) or fail (for not ok). They are synonyms for |
603 | ok(1) and ok(0). |
604 | |
605 | Use these very, very, very sparingly. |
606 | |
607 | =cut |
608 | |
d020a79a |
609 | sub pass (;$) { |
33459055 |
610 | $Test->ok(1, @_); |
3f2ec160 |
611 | } |
612 | |
d020a79a |
613 | sub fail (;$) { |
33459055 |
614 | $Test->ok(0, @_); |
3f2ec160 |
615 | } |
616 | |
617 | =back |
618 | |
a9153838 |
619 | =head2 Diagnostics |
620 | |
621 | If you pick the right test function, you'll usually get a good idea of |
622 | what went wrong when it failed. But sometimes it doesn't work out |
623 | that way. So here we have ways for you to write your own diagnostic |
624 | messages which are safer than just C<print STDERR>. |
625 | |
626 | =over 4 |
627 | |
628 | =item B<diag> |
629 | |
630 | diag(@diagnostic_message); |
631 | |
632 | Prints a diagnostic message which is guaranteed not to interfere with |
7483b81c |
633 | test output. Like C<print> @diagnostic_message is simply concatinated |
634 | together. |
635 | |
636 | Handy for this sort of thing: |
a9153838 |
637 | |
638 | ok( grep(/foo/, @users), "There's a foo user" ) or |
639 | diag("Since there's no foo, check that /etc/bar is set up right"); |
640 | |
641 | which would produce: |
642 | |
643 | not ok 42 - There's a foo user |
644 | # Failed test (foo.t at line 52) |
645 | # Since there's no foo, check that /etc/bar is set up right. |
646 | |
647 | You might remember C<ok() or diag()> with the mnemonic C<open() or |
648 | die()>. |
649 | |
30e302f8 |
650 | All diag()s can be made silent by passing the "no_diag" option to |
651 | Test::More. C<use Test::More tests => 1, 'no_diag'>. This is useful |
652 | if you have diagnostics for personal testing but then wish to make |
653 | them silent for release without commenting out each individual |
654 | statement. |
655 | |
a9153838 |
656 | B<NOTE> The exact formatting of the diagnostic output is still |
657 | changing, but it is guaranteed that whatever you throw at it it won't |
658 | interfere with the test. |
659 | |
660 | =cut |
661 | |
662 | sub diag { |
30e302f8 |
663 | return unless $Show_Diag; |
a9153838 |
664 | $Test->diag(@_); |
665 | } |
666 | |
667 | |
668 | =back |
669 | |
3f2ec160 |
670 | =head2 Module tests |
671 | |
672 | You usually want to test if the module you're testing loads ok, rather |
673 | than just vomiting if its load fails. For such purposes we have |
674 | C<use_ok> and C<require_ok>. |
675 | |
676 | =over 4 |
677 | |
678 | =item B<use_ok> |
679 | |
3f2ec160 |
680 | BEGIN { use_ok($module); } |
d020a79a |
681 | BEGIN { use_ok($module, @imports); } |
682 | |
683 | These simply use the given $module and test to make sure the load |
89c1e84a |
684 | happened ok. It's recommended that you run use_ok() inside a BEGIN |
d020a79a |
685 | block so its functions are exported at compile-time and prototypes are |
686 | properly honored. |
687 | |
688 | If @imports are given, they are passed through to the use. So this: |
689 | |
690 | BEGIN { use_ok('Some::Module', qw(foo bar)) } |
691 | |
692 | is like doing this: |
693 | |
694 | use Some::Module qw(foo bar); |
3f2ec160 |
695 | |
30e302f8 |
696 | Version numbers can be checked like so: |
697 | |
698 | # Just like "use Some::Module 1.02" |
699 | BEGIN { use_ok('Some::Module', 1.02) } |
700 | |
701 | Don't try to do this: |
a344be10 |
702 | |
703 | BEGIN { |
704 | use_ok('Some::Module'); |
705 | |
706 | ...some code that depends on the use... |
707 | ...happening at compile time... |
708 | } |
709 | |
30e302f8 |
710 | because the notion of "compile-time" is relative. Instead, you want: |
a344be10 |
711 | |
712 | BEGIN { use_ok('Some::Module') } |
713 | BEGIN { ...some code that depends on the use... } |
714 | |
3f2ec160 |
715 | |
716 | =cut |
717 | |
d020a79a |
718 | sub use_ok ($;@) { |
719 | my($module, @imports) = @_; |
720 | @imports = () unless @imports; |
3f2ec160 |
721 | |
30e302f8 |
722 | my($pack,$filename,$line) = caller; |
3f2ec160 |
723 | |
a9153838 |
724 | local($@,$!); # eval sometimes interferes with $! |
30e302f8 |
725 | |
726 | if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { |
727 | # probably a version check. Perl needs to see the bare number |
728 | # for it to work with non-Exporter based modules. |
729 | eval <<USE; |
3f2ec160 |
730 | package $pack; |
30e302f8 |
731 | use $module $imports[0]; |
3f2ec160 |
732 | USE |
30e302f8 |
733 | } |
734 | else { |
735 | eval <<USE; |
736 | package $pack; |
737 | use $module \@imports; |
738 | USE |
739 | } |
3f2ec160 |
740 | |
33459055 |
741 | my $ok = $Test->ok( !$@, "use $module;" ); |
3f2ec160 |
742 | |
743 | unless( $ok ) { |
0cd946aa |
744 | chomp $@; |
30e302f8 |
745 | $@ =~ s{^BEGIN failed--compilation aborted at .*$} |
746 | {BEGIN failed--compilation aborted at $filename line $line.}m; |
33459055 |
747 | $Test->diag(<<DIAGNOSTIC); |
a9153838 |
748 | Tried to use '$module'. |
749 | Error: $@ |
3f2ec160 |
750 | DIAGNOSTIC |
751 | |
752 | } |
753 | |
754 | return $ok; |
755 | } |
756 | |
d020a79a |
757 | =item B<require_ok> |
758 | |
759 | require_ok($module); |
7483b81c |
760 | require_ok($file); |
d020a79a |
761 | |
7483b81c |
762 | Like use_ok(), except it requires the $module or $file. |
d020a79a |
763 | |
764 | =cut |
3f2ec160 |
765 | |
766 | sub require_ok ($) { |
767 | my($module) = shift; |
768 | |
769 | my $pack = caller; |
770 | |
7483b81c |
771 | # Try to deterine if we've been given a module name or file. |
772 | # Module names must be barewords, files not. |
773 | $module = qq['$module'] unless _is_module_name($module); |
774 | |
a9153838 |
775 | local($!, $@); # eval sometimes interferes with $! |
3f2ec160 |
776 | eval <<REQUIRE; |
777 | package $pack; |
778 | require $module; |
779 | REQUIRE |
780 | |
33459055 |
781 | my $ok = $Test->ok( !$@, "require $module;" ); |
3f2ec160 |
782 | |
783 | unless( $ok ) { |
0cd946aa |
784 | chomp $@; |
33459055 |
785 | $Test->diag(<<DIAGNOSTIC); |
a9153838 |
786 | Tried to require '$module'. |
787 | Error: $@ |
3f2ec160 |
788 | DIAGNOSTIC |
789 | |
790 | } |
791 | |
792 | return $ok; |
793 | } |
794 | |
7483b81c |
795 | |
796 | sub _is_module_name { |
797 | my $module = shift; |
798 | |
799 | # Module names start with a letter. |
800 | # End with an alphanumeric. |
801 | # The rest is an alphanumeric or :: |
802 | $module =~ s/\b::\b//g; |
5143c659 |
803 | $module =~ /^[a-zA-Z]\w*$/; |
7483b81c |
804 | } |
805 | |
d020a79a |
806 | =back |
3f2ec160 |
807 | |
808 | =head2 Conditional tests |
809 | |
810 | Sometimes running a test under certain conditions will cause the |
811 | test script to die. A certain function or method isn't implemented |
812 | (such as fork() on MacOS), some resource isn't available (like a |
d020a79a |
813 | net connection) or a module isn't available. In these cases it's |
814 | necessary to skip tests, or declare that they are supposed to fail |
3f2ec160 |
815 | but will work in the future (a todo test). |
816 | |
a9153838 |
817 | For more details on the mechanics of skip and todo tests see |
818 | L<Test::Harness>. |
d020a79a |
819 | |
820 | The way Test::More handles this is with a named block. Basically, a |
821 | block of tests which can be skipped over or made todo. It's best if I |
822 | just show you... |
3f2ec160 |
823 | |
824 | =over 4 |
825 | |
d020a79a |
826 | =item B<SKIP: BLOCK> |
827 | |
828 | SKIP: { |
829 | skip $why, $how_many if $condition; |
3f2ec160 |
830 | |
d020a79a |
831 | ...normal testing code goes here... |
832 | } |
3f2ec160 |
833 | |
a344be10 |
834 | This declares a block of tests that might be skipped, $how_many tests |
835 | there are, $why and under what $condition to skip them. An example is |
836 | the easiest way to illustrate: |
3f2ec160 |
837 | |
d020a79a |
838 | SKIP: { |
a344be10 |
839 | eval { require HTML::Lint }; |
3f2ec160 |
840 | |
a344be10 |
841 | skip "HTML::Lint not installed", 2 if $@; |
d020a79a |
842 | |
a344be10 |
843 | my $lint = new HTML::Lint; |
60ffb308 |
844 | isa_ok( $lint, "HTML::Lint" ); |
3f2ec160 |
845 | |
a344be10 |
846 | $lint->parse( $html ); |
60ffb308 |
847 | is( $lint->errors, 0, "No errors found in HTML" ); |
a344be10 |
848 | } |
d020a79a |
849 | |
a344be10 |
850 | If the user does not have HTML::Lint installed, the whole block of |
851 | code I<won't be run at all>. Test::More will output special ok's |
852 | which Test::Harness interprets as skipped, but passing, tests. |
0257f296 |
853 | |
a344be10 |
854 | It's important that $how_many accurately reflects the number of tests |
855 | in the SKIP block so the # of tests run will match up with your plan. |
0257f296 |
856 | If your plan is C<no_plan> $how_many is optional and will default to 1. |
a9153838 |
857 | |
a344be10 |
858 | It's perfectly safe to nest SKIP blocks. Each SKIP block must have |
859 | the label C<SKIP>, or Test::More can't work its magic. |
a9153838 |
860 | |
861 | You don't skip tests which are failing because there's a bug in your |
a344be10 |
862 | program, or for which you don't yet have code written. For that you |
863 | use TODO. Read on. |
3f2ec160 |
864 | |
865 | =cut |
866 | |
d020a79a |
867 | #'# |
1af51bd3 |
868 | sub skip { |
d020a79a |
869 | my($why, $how_many) = @_; |
33459055 |
870 | |
871 | unless( defined $how_many ) { |
d020a79a |
872 | # $how_many can only be avoided when no_plan is in use. |
33459055 |
873 | _carp "skip() needs to know \$how_many tests are in the block" |
0257f296 |
874 | unless $Test->has_plan eq 'no_plan'; |
d020a79a |
875 | $how_many = 1; |
876 | } |
877 | |
878 | for( 1..$how_many ) { |
33459055 |
879 | $Test->skip($why); |
d020a79a |
880 | } |
881 | |
882 | local $^W = 0; |
883 | last SKIP; |
3f2ec160 |
884 | } |
885 | |
3f2ec160 |
886 | |
d020a79a |
887 | =item B<TODO: BLOCK> |
3f2ec160 |
888 | |
d020a79a |
889 | TODO: { |
a9153838 |
890 | local $TODO = $why if $condition; |
3f2ec160 |
891 | |
d020a79a |
892 | ...normal testing code goes here... |
893 | } |
3f2ec160 |
894 | |
d020a79a |
895 | Declares a block of tests you expect to fail and $why. Perhaps it's |
896 | because you haven't fixed a bug or haven't finished a new feature: |
3f2ec160 |
897 | |
d020a79a |
898 | TODO: { |
899 | local $TODO = "URI::Geller not finished"; |
3f2ec160 |
900 | |
d020a79a |
901 | my $card = "Eight of clubs"; |
902 | is( URI::Geller->your_card, $card, 'Is THIS your card?' ); |
3f2ec160 |
903 | |
d020a79a |
904 | my $spoon; |
905 | URI::Geller->bend_spoon; |
906 | is( $spoon, 'bent', "Spoon bending, that's original" ); |
907 | } |
908 | |
909 | With a todo block, the tests inside are expected to fail. Test::More |
910 | will run the tests normally, but print out special flags indicating |
911 | they are "todo". Test::Harness will interpret failures as being ok. |
912 | Should anything succeed, it will report it as an unexpected success. |
a344be10 |
913 | You then know the thing you had todo is done and can remove the |
914 | TODO flag. |
d020a79a |
915 | |
916 | The nice part about todo tests, as opposed to simply commenting out a |
4bd4e70a |
917 | block of tests, is it's like having a programmatic todo list. You know |
d020a79a |
918 | how much work is left to be done, you're aware of what bugs there are, |
919 | and you'll know immediately when they're fixed. |
920 | |
921 | Once a todo test starts succeeding, simply move it outside the block. |
922 | When the block is empty, delete it. |
923 | |
30e302f8 |
924 | B<NOTE>: TODO tests require a Test::Harness upgrade else it will |
925 | treat it as a normal failure. See L<BUGS and CAVEATS>) |
926 | |
d020a79a |
927 | |
a9153838 |
928 | =item B<todo_skip> |
929 | |
930 | TODO: { |
931 | todo_skip $why, $how_many if $condition; |
932 | |
933 | ...normal testing code... |
934 | } |
935 | |
89c1e84a |
936 | With todo tests, it's best to have the tests actually run. That way |
a9153838 |
937 | you'll know when they start passing. Sometimes this isn't possible. |
938 | Often a failing test will cause the whole program to die or hang, even |
939 | inside an C<eval BLOCK> with and using C<alarm>. In these extreme |
940 | cases you have no choice but to skip over the broken tests entirely. |
941 | |
942 | The syntax and behavior is similar to a C<SKIP: BLOCK> except the |
943 | tests will be marked as failing but todo. Test::Harness will |
944 | interpret them as passing. |
945 | |
946 | =cut |
947 | |
948 | sub todo_skip { |
949 | my($why, $how_many) = @_; |
950 | |
951 | unless( defined $how_many ) { |
952 | # $how_many can only be avoided when no_plan is in use. |
953 | _carp "todo_skip() needs to know \$how_many tests are in the block" |
0257f296 |
954 | unless $Test->has_plan eq 'no_plan'; |
a9153838 |
955 | $how_many = 1; |
956 | } |
957 | |
958 | for( 1..$how_many ) { |
959 | $Test->todo_skip($why); |
960 | } |
961 | |
962 | local $^W = 0; |
963 | last TODO; |
964 | } |
965 | |
a344be10 |
966 | =item When do I use SKIP vs. TODO? |
967 | |
968 | B<If it's something the user might not be able to do>, use SKIP. |
969 | This includes optional modules that aren't installed, running under |
970 | an OS that doesn't have some feature (like fork() or symlinks), or maybe |
971 | you need an Internet connection and one isn't available. |
972 | |
973 | B<If it's something the programmer hasn't done yet>, use TODO. This |
974 | is for any code you haven't written yet, or bugs you have yet to fix, |
975 | but want to put tests in your testing script (always a good idea). |
976 | |
a9153838 |
977 | |
d020a79a |
978 | =back |
3f2ec160 |
979 | |
5143c659 |
980 | =head2 Complex data structures |
3f2ec160 |
981 | |
982 | Not everything is a simple eq check or regex. There are times you |
5143c659 |
983 | need to see if two data structures are equivalent. For these |
984 | instances Test::More provides a handful of useful functions. |
3f2ec160 |
985 | |
7483b81c |
986 | B<NOTE> I'm not quite sure what will happen with filehandles. |
3f2ec160 |
987 | |
988 | =over 4 |
989 | |
33459055 |
990 | =item B<is_deeply> |
991 | |
992 | is_deeply( $this, $that, $test_name ); |
993 | |
994 | Similar to is(), except that if $this and $that are hash or array |
995 | references, it does a deep comparison walking each data structure to |
996 | see if they are equivalent. If the two structures are different, it |
997 | will display the place where they start differing. |
998 | |
30e302f8 |
999 | Test::Differences and Test::Deep provide more in-depth functionality |
1000 | along these lines. |
33459055 |
1001 | |
1002 | =cut |
1003 | |
7483b81c |
1004 | use vars qw(@Data_Stack %Refs_Seen); |
33459055 |
1005 | my $DNE = bless [], 'Does::Not::Exist'; |
1006 | sub is_deeply { |
30e302f8 |
1007 | unless( @_ == 2 or @_ == 3 ) { |
1008 | my $msg = <<WARNING; |
1009 | is_deeply() takes two or three args, you gave %d. |
1010 | This usually means you passed an array or hash instead |
1011 | of a reference to it |
1012 | WARNING |
1013 | chop $msg; # clip off newline so carp() will put in line/file |
1014 | |
1015 | _carp sprintf $msg, scalar @_; |
5143c659 |
1016 | |
1017 | return $Test->ok(0); |
30e302f8 |
1018 | } |
1019 | |
33459055 |
1020 | my($this, $that, $name) = @_; |
1021 | |
1022 | my $ok; |
5143c659 |
1023 | if( !ref $this and !ref $that ) { # neither is a reference |
33459055 |
1024 | $ok = $Test->is_eq($this, $that, $name); |
1025 | } |
5143c659 |
1026 | elsif( !ref $this xor !ref $that ) { # one's a reference, one isn't |
1027 | $ok = $Test->ok(0, $name); |
1028 | $Test->diag( _format_stack({ vals => [ $this, $that ] }) ); |
1029 | } |
1030 | else { # both references |
33459055 |
1031 | local @Data_Stack = (); |
1032 | if( _deep_check($this, $that) ) { |
1033 | $ok = $Test->ok(1, $name); |
1034 | } |
1035 | else { |
1036 | $ok = $Test->ok(0, $name); |
5143c659 |
1037 | $Test->diag(_format_stack(@Data_Stack)); |
33459055 |
1038 | } |
1039 | } |
1040 | |
1041 | return $ok; |
1042 | } |
1043 | |
1044 | sub _format_stack { |
1045 | my(@Stack) = @_; |
1046 | |
1047 | my $var = '$FOO'; |
1048 | my $did_arrow = 0; |
1049 | foreach my $entry (@Stack) { |
1050 | my $type = $entry->{type} || ''; |
1051 | my $idx = $entry->{'idx'}; |
1052 | if( $type eq 'HASH' ) { |
1053 | $var .= "->" unless $did_arrow++; |
1054 | $var .= "{$idx}"; |
1055 | } |
1056 | elsif( $type eq 'ARRAY' ) { |
1057 | $var .= "->" unless $did_arrow++; |
1058 | $var .= "[$idx]"; |
1059 | } |
1060 | elsif( $type eq 'REF' ) { |
1061 | $var = "\${$var}"; |
1062 | } |
1063 | } |
1064 | |
1065 | my @vals = @{$Stack[-1]{vals}}[0,1]; |
1066 | my @vars = (); |
1067 | ($vars[0] = $var) =~ s/\$FOO/ \$got/; |
1068 | ($vars[1] = $var) =~ s/\$FOO/\$expected/; |
1069 | |
1070 | my $out = "Structures begin differing at:\n"; |
1071 | foreach my $idx (0..$#vals) { |
1072 | my $val = $vals[$idx]; |
5143c659 |
1073 | $vals[$idx] = !defined $val ? 'undef' : |
1074 | $val eq $DNE ? "Does not exist" : |
1075 | ref $val ? "$val" : |
1076 | "'$val'"; |
33459055 |
1077 | } |
1078 | |
1079 | $out .= "$vars[0] = $vals[0]\n"; |
1080 | $out .= "$vars[1] = $vals[1]\n"; |
1081 | |
a9153838 |
1082 | $out =~ s/^/ /msg; |
33459055 |
1083 | return $out; |
1084 | } |
1085 | |
1086 | |
0257f296 |
1087 | sub _type { |
1088 | my $thing = shift; |
1089 | |
1090 | return '' if !ref $thing; |
1091 | |
1092 | for my $type (qw(ARRAY HASH REF SCALAR GLOB Regexp)) { |
1093 | return $type if UNIVERSAL::isa($thing, $type); |
1094 | } |
1095 | |
1096 | return ''; |
1097 | } |
1098 | |
1099 | |
5143c659 |
1100 | =head2 Discouraged comparison functions |
1101 | |
1102 | The use of the following functions is discouraged as they are not |
1103 | actually testing functions and produce no diagnostics to help figure |
1104 | out what went wrong. They were written before is_deeply() existed |
1105 | because I couldn't figure out how to display a useful diff of two |
1106 | arbitrary data structures. |
1107 | |
1108 | These functions are usually used inside an ok(). |
1109 | |
1110 | ok( eq_array(\@this, \@that) ); |
1111 | |
1112 | C<is_deeply()> can do that better and with diagnostics. |
1113 | |
1114 | is_deeply( \@this, \@that ); |
1115 | |
1116 | They may be deprecated in future versions. |
1117 | |
1118 | |
3f2ec160 |
1119 | =item B<eq_array> |
1120 | |
5143c659 |
1121 | my $is_eq = eq_array(\@this, \@that); |
3f2ec160 |
1122 | |
1123 | Checks if two arrays are equivalent. This is a deep check, so |
1124 | multi-level structures are handled correctly. |
1125 | |
1126 | =cut |
1127 | |
1128 | #'# |
7483b81c |
1129 | sub eq_array { |
1130 | local @Data_Stack; |
5143c659 |
1131 | _deep_check(@_); |
7483b81c |
1132 | } |
1133 | |
1134 | sub _eq_array { |
3f2ec160 |
1135 | my($a1, $a2) = @_; |
7483b81c |
1136 | |
0257f296 |
1137 | if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) { |
7483b81c |
1138 | warn "eq_array passed a non-array ref"; |
1139 | return 0; |
1140 | } |
1141 | |
3f2ec160 |
1142 | return 1 if $a1 eq $a2; |
1143 | |
1144 | my $ok = 1; |
33459055 |
1145 | my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; |
1146 | for (0..$max) { |
1147 | my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; |
1148 | my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; |
1149 | |
1150 | push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] }; |
3f2ec160 |
1151 | $ok = _deep_check($e1,$e2); |
33459055 |
1152 | pop @Data_Stack if $ok; |
1153 | |
3f2ec160 |
1154 | last unless $ok; |
1155 | } |
7483b81c |
1156 | |
3f2ec160 |
1157 | return $ok; |
1158 | } |
1159 | |
1160 | sub _deep_check { |
1161 | my($e1, $e2) = @_; |
1162 | my $ok = 0; |
1163 | |
5143c659 |
1164 | # Effectively turn %Refs_Seen into a stack. This avoids picking up |
1165 | # the same referenced used twice (such as [\$a, \$a]) to be considered |
1166 | # circular. |
1167 | local %Refs_Seen = %Refs_Seen; |
1168 | |
d020a79a |
1169 | { |
4bd4e70a |
1170 | # Quiet uninitialized value warnings when comparing undefs. |
d020a79a |
1171 | local $^W = 0; |
1172 | |
7483b81c |
1173 | $Test->_unoverload(\$e1, \$e2); |
1174 | |
1175 | # Either they're both references or both not. |
1176 | my $same_ref = !(!ref $e1 xor !ref $e2); |
5143c659 |
1177 | my $not_ref = (!ref $e1 and !ref $e2); |
7483b81c |
1178 | |
1179 | if( defined $e1 xor defined $e2 ) { |
1180 | $ok = 0; |
1181 | } |
1182 | elsif ( $e1 == $DNE xor $e2 == $DNE ) { |
1183 | $ok = 0; |
1184 | } |
1185 | elsif ( $same_ref and ($e1 eq $e2) ) { |
d020a79a |
1186 | $ok = 1; |
3f2ec160 |
1187 | } |
5143c659 |
1188 | elsif ( $not_ref ) { |
1189 | push @Data_Stack, { type => '', vals => [$e1, $e2] }; |
1190 | $ok = 0; |
1191 | } |
3f2ec160 |
1192 | else { |
5143c659 |
1193 | if( $Refs_Seen{$e1} ) { |
1194 | return $Refs_Seen{$e1} eq $e2; |
1195 | } |
1196 | else { |
1197 | $Refs_Seen{$e1} = "$e2"; |
1198 | } |
1199 | |
0257f296 |
1200 | my $type = _type($e1); |
5143c659 |
1201 | $type = 'DIFFERENT' unless _type($e2) eq $type; |
0257f296 |
1202 | |
5143c659 |
1203 | if( $type eq 'DIFFERENT' ) { |
1204 | push @Data_Stack, { type => $type, vals => [$e1, $e2] }; |
0257f296 |
1205 | $ok = 0; |
1206 | } |
1207 | elsif( $type eq 'ARRAY' ) { |
7483b81c |
1208 | $ok = _eq_array($e1, $e2); |
d020a79a |
1209 | } |
0257f296 |
1210 | elsif( $type eq 'HASH' ) { |
7483b81c |
1211 | $ok = _eq_hash($e1, $e2); |
d020a79a |
1212 | } |
0257f296 |
1213 | elsif( $type eq 'REF' ) { |
5143c659 |
1214 | push @Data_Stack, { type => $type, vals => [$e1, $e2] }; |
33459055 |
1215 | $ok = _deep_check($$e1, $$e2); |
1216 | pop @Data_Stack if $ok; |
1217 | } |
0257f296 |
1218 | elsif( $type eq 'SCALAR' ) { |
33459055 |
1219 | push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; |
1220 | $ok = _deep_check($$e1, $$e2); |
7483b81c |
1221 | pop @Data_Stack if $ok; |
33459055 |
1222 | } |
5143c659 |
1223 | else { |
1224 | _whoa(1, "No type in _deep_check"); |
1225 | } |
3f2ec160 |
1226 | } |
1227 | } |
d020a79a |
1228 | |
3f2ec160 |
1229 | return $ok; |
1230 | } |
1231 | |
1232 | |
5143c659 |
1233 | sub _whoa { |
1234 | my($check, $desc) = @_; |
1235 | if( $check ) { |
1236 | die <<WHOA; |
1237 | WHOA! $desc |
1238 | This should never happen! Please contact the author immediately! |
1239 | WHOA |
1240 | } |
1241 | } |
1242 | |
1243 | |
3f2ec160 |
1244 | =item B<eq_hash> |
1245 | |
5143c659 |
1246 | my $is_eq = eq_hash(\%this, \%that); |
3f2ec160 |
1247 | |
1248 | Determines if the two hashes contain the same keys and values. This |
1249 | is a deep check. |
1250 | |
1251 | =cut |
1252 | |
1253 | sub eq_hash { |
7483b81c |
1254 | local @Data_Stack; |
5143c659 |
1255 | return _deep_check(@_); |
7483b81c |
1256 | } |
1257 | |
1258 | sub _eq_hash { |
3f2ec160 |
1259 | my($a1, $a2) = @_; |
7483b81c |
1260 | |
0257f296 |
1261 | if( grep !_type($_) eq 'HASH', $a1, $a2 ) { |
7483b81c |
1262 | warn "eq_hash passed a non-hash ref"; |
1263 | return 0; |
1264 | } |
1265 | |
3f2ec160 |
1266 | return 1 if $a1 eq $a2; |
1267 | |
1268 | my $ok = 1; |
33459055 |
1269 | my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; |
1270 | foreach my $k (keys %$bigger) { |
1271 | my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; |
1272 | my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; |
1273 | |
1274 | push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] }; |
3f2ec160 |
1275 | $ok = _deep_check($e1, $e2); |
33459055 |
1276 | pop @Data_Stack if $ok; |
1277 | |
3f2ec160 |
1278 | last unless $ok; |
1279 | } |
1280 | |
1281 | return $ok; |
1282 | } |
1283 | |
1284 | =item B<eq_set> |
1285 | |
5143c659 |
1286 | my $is_eq = eq_set(\@this, \@that); |
3f2ec160 |
1287 | |
1288 | Similar to eq_array(), except the order of the elements is B<not> |
1289 | important. This is a deep check, but the irrelevancy of order only |
1290 | applies to the top level. |
1291 | |
5143c659 |
1292 | ok( eq_set(\@this, \@that) ); |
1293 | |
1294 | Is better written: |
1295 | |
1296 | is_deeply( [sort @this], [sort @that] ); |
1297 | |
60ffb308 |
1298 | B<NOTE> By historical accident, this is not a true set comparision. |
1299 | While the order of elements does not matter, duplicate elements do. |
1300 | |
5143c659 |
1301 | Test::Deep contains much better set comparison functions. |
1302 | |
3f2ec160 |
1303 | =cut |
1304 | |
3f2ec160 |
1305 | sub eq_set { |
1306 | my($a1, $a2) = @_; |
1307 | return 0 unless @$a1 == @$a2; |
1308 | |
1309 | # There's faster ways to do this, but this is easiest. |
7483b81c |
1310 | local $^W = 0; |
1311 | |
1312 | # We must make sure that references are treated neutrally. It really |
1313 | # doesn't matter how we sort them, as long as both arrays are sorted |
1314 | # with the same algorithm. |
1315 | # Have to inline the sort routine due to a threading/sort bug. |
1316 | # See [rt.cpan.org 6782] |
1317 | return eq_array( |
1318 | [sort { ref $a ? -1 : ref $b ? 1 : $a cmp $b } @$a1], |
1319 | [sort { ref $a ? -1 : ref $b ? 1 : $a cmp $b } @$a2] |
1320 | ); |
3f2ec160 |
1321 | } |
1322 | |
3f2ec160 |
1323 | =back |
1324 | |
d020a79a |
1325 | |
a9153838 |
1326 | =head2 Extending and Embedding Test::More |
d020a79a |
1327 | |
a9153838 |
1328 | Sometimes the Test::More interface isn't quite enough. Fortunately, |
1329 | Test::More is built on top of Test::Builder which provides a single, |
1330 | unified backend for any test library to use. This means two test |
1331 | libraries which both use Test::Builder B<can be used together in the |
1332 | same program>. |
1333 | |
1334 | If you simply want to do a little tweaking of how the tests behave, |
1335 | you can access the underlying Test::Builder object like so: |
3f2ec160 |
1336 | |
d020a79a |
1337 | =over 4 |
1338 | |
a9153838 |
1339 | =item B<builder> |
d020a79a |
1340 | |
a9153838 |
1341 | my $test_builder = Test::More->builder; |
d020a79a |
1342 | |
a9153838 |
1343 | Returns the Test::Builder object underlying Test::More for you to play |
1344 | with. |
1345 | |
1346 | =cut |
d020a79a |
1347 | |
a9153838 |
1348 | sub builder { |
1349 | return Test::Builder->new; |
1350 | } |
d020a79a |
1351 | |
a9153838 |
1352 | =back |
3f2ec160 |
1353 | |
d020a79a |
1354 | |
30e302f8 |
1355 | =head1 EXIT CODES |
1356 | |
1357 | If all your tests passed, Test::Builder will exit with zero (which is |
1358 | normal). If anything failed it will exit with how many failed. If |
1359 | you run less (or more) tests than you planned, the missing (or extras) |
1360 | will be considered failures. If no tests were ever run Test::Builder |
1361 | will throw a warning and exit with 255. If the test died, even after |
1362 | having successfully completed all its tests, it will still be |
1363 | considered a failure and will exit with 255. |
1364 | |
1365 | So the exit codes are... |
1366 | |
1367 | 0 all tests successful |
1368 | 255 test died |
1369 | any other number how many failed (including missing or extras) |
1370 | |
1371 | If you fail more than 254 tests, it will be reported as 254. |
1372 | |
5143c659 |
1373 | B<NOTE> This behavior may go away in future versions. |
1374 | |
30e302f8 |
1375 | |
7483b81c |
1376 | =head1 CAVEATS and NOTES |
a9153838 |
1377 | |
7483b81c |
1378 | =over 4 |
d020a79a |
1379 | |
7483b81c |
1380 | =item Backwards compatibility |
1381 | |
1382 | Test::More works with Perls as old as 5.004_05. |
1383 | |
1384 | |
1385 | =item Overloaded objects |
1386 | |
1387 | String overloaded objects are compared B<as strings>. This prevents |
1388 | Test::More from piercing an object's interface allowing better blackbox |
1389 | testing. So if a function starts returning overloaded objects instead of |
1390 | bare strings your tests won't notice the difference. This is good. |
1391 | |
1392 | However, it does mean that functions like is_deeply() cannot be used to |
1393 | test the internals of string overloaded objects. In this case I would |
1394 | suggest Test::Deep which contains more flexible testing functions for |
1395 | complex data structures. |
a9153838 |
1396 | |
a9153838 |
1397 | |
30e302f8 |
1398 | =item Threads |
1399 | |
1400 | Test::More will only be aware of threads if "use threads" has been done |
1401 | I<before> Test::More is loaded. This is ok: |
1402 | |
1403 | use threads; |
1404 | use Test::More; |
1405 | |
1406 | This may cause problems: |
1407 | |
1408 | use Test::More |
1409 | use threads; |
1410 | |
d020a79a |
1411 | |
30e302f8 |
1412 | =item Test::Harness upgrade |
3f2ec160 |
1413 | |
d020a79a |
1414 | no_plan and todo depend on new Test::Harness features and fixes. If |
a9153838 |
1415 | you're going to distribute tests that use no_plan or todo your |
1416 | end-users will have to upgrade Test::Harness to the latest one on |
1417 | CPAN. If you avoid no_plan and TODO tests, the stock Test::Harness |
1418 | will work fine. |
d020a79a |
1419 | |
30e302f8 |
1420 | Installing Test::More should also upgrade Test::Harness. |
d020a79a |
1421 | |
1422 | =back |
3f2ec160 |
1423 | |
3f2ec160 |
1424 | |
1425 | =head1 HISTORY |
1426 | |
1427 | This is a case of convergent evolution with Joshua Pritikin's Test |
4bd4e70a |
1428 | module. I was largely unaware of its existence when I'd first |
3f2ec160 |
1429 | written my own ok() routines. This module exists because I can't |
1430 | figure out how to easily wedge test names into Test's interface (along |
1431 | with a few other problems). |
1432 | |
1433 | The goal here is to have a testing utility that's simple to learn, |
1434 | quick to use and difficult to trip yourself up with while still |
1435 | providing more flexibility than the existing Test.pm. As such, the |
1436 | names of the most common routines are kept tiny, special cases and |
1437 | magic side-effects are kept to a minimum. WYSIWYG. |
1438 | |
1439 | |
1440 | =head1 SEE ALSO |
1441 | |
1442 | L<Test::Simple> if all this confuses you and you just want to write |
89c1e84a |
1443 | some tests. You can upgrade to Test::More later (it's forward |
3f2ec160 |
1444 | compatible). |
1445 | |
a9153838 |
1446 | L<Test> is the old testing module. Its main benefit is that it has |
1447 | been distributed with Perl since 5.004_05. |
3f2ec160 |
1448 | |
1449 | L<Test::Harness> for details on how your test results are interpreted |
1450 | by Perl. |
1451 | |
30e302f8 |
1452 | L<Test::Differences> for more ways to test complex data structures. |
1453 | And it plays well with Test::More. |
1454 | |
1455 | L<Test::Class> is like XUnit but more perlish. |
1456 | |
1457 | L<Test::Deep> gives you more powerful complex data structure testing. |
1458 | |
1459 | L<Test::Unit> is XUnit style testing. |
3f2ec160 |
1460 | |
4bd4e70a |
1461 | L<Test::Inline> shows the idea of embedded testing. |
3f2ec160 |
1462 | |
30e302f8 |
1463 | L<Bundle::Test> installs a whole bunch of useful test modules. |
3f2ec160 |
1464 | |
4bd4e70a |
1465 | |
1466 | =head1 AUTHORS |
1467 | |
a9153838 |
1468 | Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration |
1469 | from Joshua Pritikin's Test module and lots of help from Barrie |
7483b81c |
1470 | Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and |
1471 | the perl-qa gang. |
1472 | |
1473 | |
1474 | =head1 BUGS |
1475 | |
1476 | See F<http://rt.cpan.org> to report and view bugs. |
4bd4e70a |
1477 | |
1478 | |
1479 | =head1 COPYRIGHT |
1480 | |
7483b81c |
1481 | Copyright 2001, 2002, 2004 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. |
4bd4e70a |
1482 | |
1483 | This program is free software; you can redistribute it and/or |
1484 | modify it under the same terms as Perl itself. |
1485 | |
a9153838 |
1486 | See F<http://www.perl.com/perl/misc/Artistic.html> |
4bd4e70a |
1487 | |
3f2ec160 |
1488 | =cut |
1489 | |
1490 | 1; |