File Coverage

blib/lib/Test/More.pm
Criterion Covered Total %
statement 338 352 96.0
branch 168 180 93.3
condition 56 67 83.5
subroutine 50 51 98.0
pod 26 27 96.3
total 638 677 94.2


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