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