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