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.302199';
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
1209my %_types = (
1210  (map +($_ => $_), qw(
1211    Regexp
1212    ARRAY
1213    HASH
1214    SCALAR
1215    REF
1216    GLOB
1217    CODE
1218  )),
1219  'LVALUE'  => 'SCALAR',
1220  'REF'     => 'SCALAR',
1221  'VSTRING' => 'SCALAR',
1222);
1223
1224sub _type {
1225    my $thing = shift;
1226
1227    return '' if !ref $thing;
1228
1229    for my $type (keys %_types) {
1230        return $_types{$type} if UNIVERSAL::isa( $thing, $type );
1231    }
1232
1233    return '';
1234}
1235
1236=back
1237
1238
1239=head2 Diagnostics
1240
1241If you pick the right test function, you'll usually get a good idea of
1242what went wrong when it failed.  But sometimes it doesn't work out
1243that way.  So here we have ways for you to write your own diagnostic
1244messages which are safer than just C<print STDERR>.
1245
1246=over 4
1247
1248=item B<diag>
1249
1250  diag(@diagnostic_message);
1251
1252Prints a diagnostic message which is guaranteed not to interfere with
1253test output.  Like C<print> @diagnostic_message is simply concatenated
1254together.
1255
1256Returns false, so as to preserve failure.
1257
1258Handy for this sort of thing:
1259
1260    ok( grep(/foo/, @users), "There's a foo user" ) or
1261        diag("Since there's no foo, check that /etc/bar is set up right");
1262
1263which would produce:
1264
1265    not ok 42 - There's a foo user
1266    #   Failed test 'There's a foo user'
1267    #   in foo.t at line 52.
1268    # Since there's no foo, check that /etc/bar is set up right.
1269
1270You might remember C<ok() or diag()> with the mnemonic C<open() or
1271die()>.
1272
1273B<NOTE> The exact formatting of the diagnostic output is still
1274changing, but it is guaranteed that whatever you throw at it won't
1275interfere with the test.
1276
1277=item B<note>
1278
1279  note(@diagnostic_message);
1280
1281Like C<diag()>, except the message will not be seen when the test is run
1282in a harness.  It will only be visible in the verbose TAP stream.
1283
1284Handy for putting in notes which might be useful for debugging, but
1285don't indicate a problem.
1286
1287    note("Tempfile is $tempfile");
1288
1289=cut
1290
1291sub diag {
1292    return Test::More->builder->diag(@_);
1293}
1294
1295sub note {
1296    return Test::More->builder->note(@_);
1297}
1298
1299=item B<explain>
1300
1301  my @dump = explain @diagnostic_message;
1302
1303Will dump the contents of any references in a human readable format.
1304Usually you want to pass this into C<note> or C<diag>.
1305
1306Handy for things like...
1307
1308    is_deeply($have, $want) || diag explain $have;
1309
1310or
1311
1312    note explain \%args;
1313    Some::Class->method(%args);
1314
1315=cut
1316
1317sub explain {
1318    return Test::More->builder->explain(@_);
1319}
1320
1321=back
1322
1323
1324=head2 Conditional tests
1325
1326Sometimes running a test under certain conditions will cause the
1327test script to die.  A certain function or method isn't implemented
1328(such as C<fork()> on MacOS), some resource isn't available (like a
1329net connection) or a module isn't available.  In these cases it's
1330necessary to skip tests, or declare that they are supposed to fail
1331but will work in the future (a todo test).
1332
1333For more details on the mechanics of skip and todo tests see
1334L<Test::Harness>.
1335
1336The way Test::More handles this is with a named block.  Basically, a
1337block of tests which can be skipped over or made todo.  It's best if I
1338just show you...
1339
1340=over 4
1341
1342=item B<SKIP: BLOCK>
1343
1344  SKIP: {
1345      skip $why, $how_many if $condition;
1346
1347      ...normal testing code goes here...
1348  }
1349
1350This declares a block of tests that might be skipped, $how_many tests
1351there are, $why and under what $condition to skip them.  An example is
1352the easiest way to illustrate:
1353
1354    SKIP: {
1355        eval { require HTML::Lint };
1356
1357        skip "HTML::Lint not installed", 2 if $@;
1358
1359        my $lint = new HTML::Lint;
1360        isa_ok( $lint, "HTML::Lint" );
1361
1362        $lint->parse( $html );
1363        is( $lint->errors, 0, "No errors found in HTML" );
1364    }
1365
1366If the user does not have HTML::Lint installed, the whole block of
1367code I<won't be run at all>.  Test::More will output special ok's
1368which Test::Harness interprets as skipped, but passing, tests.
1369
1370It's important that $how_many accurately reflects the number of tests
1371in the SKIP block so the # of tests run will match up with your plan.
1372If your plan is C<no_plan> $how_many is optional and will default to 1.
1373
1374It's perfectly safe to nest SKIP blocks.  Each SKIP block must have
1375the label C<SKIP>, or Test::More can't work its magic.
1376
1377You don't skip tests which are failing because there's a bug in your
1378program, or for which you don't yet have code written.  For that you
1379use TODO.  Read on.
1380
1381=cut
1382
1383## no critic (Subroutines::RequireFinalReturn)
1384sub skip {
1385    my( $why, $how_many ) = @_;
1386    my $tb = Test::More->builder;
1387
1388    # If the plan is set, and is static, then skip needs a count. If the plan
1389    # is 'no_plan' we are fine. As well if plan is undefined then we are
1390    # waiting for done_testing.
1391    unless (defined $how_many) {
1392        my $plan = $tb->has_plan;
1393        _carp "skip() needs to know \$how_many tests are in the block"
1394            if $plan && $plan =~ m/^\d+$/;
1395        $how_many = 1;
1396    }
1397
1398    if( defined $how_many and $how_many =~ /\D/ ) {
1399        _carp
1400          "skip() was passed a non-numeric number of tests.  Did you get the arguments backwards?";
1401        $how_many = 1;
1402    }
1403
1404    for( 1 .. $how_many ) {
1405        $tb->skip($why);
1406    }
1407
1408    no warnings 'exiting';
1409    last SKIP;
1410}
1411
1412=item B<TODO: BLOCK>
1413
1414    TODO: {
1415        local $TODO = $why if $condition;
1416
1417        ...normal testing code goes here...
1418    }
1419
1420Declares a block of tests you expect to fail and $why.  Perhaps it's
1421because you haven't fixed a bug or haven't finished a new feature:
1422
1423    TODO: {
1424        local $TODO = "URI::Geller not finished";
1425
1426        my $card = "Eight of clubs";
1427        is( URI::Geller->your_card, $card, 'Is THIS your card?' );
1428
1429        my $spoon;
1430        URI::Geller->bend_spoon;
1431        is( $spoon, 'bent',    "Spoon bending, that's original" );
1432    }
1433
1434With a todo block, the tests inside are expected to fail.  Test::More
1435will run the tests normally, but print out special flags indicating
1436they are "todo".  L<Test::Harness> will interpret failures as being ok.
1437Should anything succeed, it will report it as an unexpected success.
1438You then know the thing you had todo is done and can remove the
1439TODO flag.
1440
1441The nice part about todo tests, as opposed to simply commenting out a
1442block of tests, is that it is like having a programmatic todo list.  You know
1443how much work is left to be done, you're aware of what bugs there are,
1444and you'll know immediately when they're fixed.
1445
1446Once a todo test starts succeeding, simply move it outside the block.
1447When the block is empty, delete it.
1448
1449Note that, if you leave $TODO unset or undef, Test::More reports failures
1450as normal. This can be useful to mark the tests as expected to fail only
1451in certain conditions, e.g.:
1452
1453    TODO: {
1454        local $TODO = "$^O doesn't work yet. :(" if !_os_is_supported($^O);
1455
1456        ...
1457    }
1458
1459=item B<todo_skip>
1460
1461    TODO: {
1462        todo_skip $why, $how_many if $condition;
1463
1464        ...normal testing code...
1465    }
1466
1467With todo tests, it's best to have the tests actually run.  That way
1468you'll know when they start passing.  Sometimes this isn't possible.
1469Often a failing test will cause the whole program to die or hang, even
1470inside an C<eval BLOCK> with and using C<alarm>.  In these extreme
1471cases you have no choice but to skip over the broken tests entirely.
1472
1473The syntax and behavior is similar to a C<SKIP: BLOCK> except the
1474tests will be marked as failing but todo.  L<Test::Harness> will
1475interpret them as passing.
1476
1477=cut
1478
1479sub todo_skip {
1480    my( $why, $how_many ) = @_;
1481    my $tb = Test::More->builder;
1482
1483    unless( defined $how_many ) {
1484        # $how_many can only be avoided when no_plan is in use.
1485        _carp "todo_skip() needs to know \$how_many tests are in the block"
1486          unless $tb->has_plan eq 'no_plan';
1487        $how_many = 1;
1488    }
1489
1490    for( 1 .. $how_many ) {
1491        $tb->todo_skip($why);
1492    }
1493
1494    no warnings 'exiting';
1495    last TODO;
1496}
1497
1498=item When do I use SKIP vs. TODO?
1499
1500B<If it's something the user might not be able to do>, use SKIP.
1501This includes optional modules that aren't installed, running under
1502an OS that doesn't have some feature (like C<fork()> or symlinks), or maybe
1503you need an Internet connection and one isn't available.
1504
1505B<If it's something the programmer hasn't done yet>, use TODO.  This
1506is for any code you haven't written yet, or bugs you have yet to fix,
1507but want to put tests in your testing script (always a good idea).
1508
1509
1510=back
1511
1512
1513=head2 Test control
1514
1515=over 4
1516
1517=item B<BAIL_OUT>
1518
1519    BAIL_OUT($reason);
1520
1521Indicates to the harness that things are going so badly all testing
1522should terminate.  This includes the running of any additional test scripts.
1523
1524This is typically used when testing cannot continue such as a critical
1525module failing to compile or a necessary external utility not being
1526available such as a database connection failing.
1527
1528The test will exit with 255.
1529
1530For even better control look at L<Test::Most>.
1531
1532=cut
1533
1534sub BAIL_OUT {
1535    my $reason = shift;
1536    my $tb     = Test::More->builder;
1537
1538    $tb->BAIL_OUT($reason);
1539}
1540
1541=back
1542
1543
1544=head2 Discouraged comparison functions
1545
1546The use of the following functions is discouraged as they are not
1547actually testing functions and produce no diagnostics to help figure
1548out what went wrong.  They were written before C<is_deeply()> existed
1549because I couldn't figure out how to display a useful diff of two
1550arbitrary data structures.
1551
1552These functions are usually used inside an C<ok()>.
1553
1554    ok( eq_array(\@got, \@expected) );
1555
1556C<is_deeply()> can do that better and with diagnostics.
1557
1558    is_deeply( \@got, \@expected );
1559
1560They may be deprecated in future versions.
1561
1562=over 4
1563
1564=item B<eq_array>
1565
1566  my $is_eq = eq_array(\@got, \@expected);
1567
1568Checks if two arrays are equivalent.  This is a deep check, so
1569multi-level structures are handled correctly.
1570
1571=cut
1572
1573#'#
1574sub eq_array {
1575    local @Data_Stack = ();
1576    _deep_check(@_);
1577}
1578
1579sub _eq_array {
1580    my( $a1, $a2 ) = @_;
1581
1582    if( grep _type($_) ne 'ARRAY', $a1, $a2 ) {
1583        warn "eq_array passed a non-array ref";
1584        return 0;
1585    }
1586
1587    return 1 if $a1 eq $a2;
1588
1589    my $ok = 1;
1590    my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
1591    for( 0 .. $max ) {
1592        my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
1593        my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
1594
1595        next if _equal_nonrefs($e1, $e2);
1596
1597        push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] };
1598        $ok = _deep_check( $e1, $e2 );
1599        pop @Data_Stack if $ok;
1600
1601        last unless $ok;
1602    }
1603
1604    return $ok;
1605}
1606
1607sub _equal_nonrefs {
1608    my( $e1, $e2 ) = @_;
1609
1610    return if ref $e1 or ref $e2;
1611
1612    if ( defined $e1 ) {
1613        return 1 if defined $e2 and $e1 eq $e2;
1614    }
1615    else {
1616        return 1 if !defined $e2;
1617    }
1618
1619    return;
1620}
1621
1622sub _deep_check {
1623    my( $e1, $e2 ) = @_;
1624    my $tb = Test::More->builder;
1625
1626    my $ok = 0;
1627
1628    # Effectively turn %Refs_Seen into a stack.  This avoids picking up
1629    # the same referenced used twice (such as [\$a, \$a]) to be considered
1630    # circular.
1631    local %Refs_Seen = %Refs_Seen;
1632
1633    {
1634        $tb->_unoverload_str( \$e1, \$e2 );
1635
1636        # Either they're both references or both not.
1637        my $same_ref = !( !ref $e1 xor !ref $e2 );
1638        my $not_ref = ( !ref $e1 and !ref $e2 );
1639
1640        if( defined $e1 xor defined $e2 ) {
1641            $ok = 0;
1642        }
1643        elsif( !defined $e1 and !defined $e2 ) {
1644            # Shortcut if they're both undefined.
1645            $ok = 1;
1646        }
1647        elsif( _dne($e1) xor _dne($e2) ) {
1648            $ok = 0;
1649        }
1650        elsif( $same_ref and( $e1 eq $e2 ) ) {
1651            $ok = 1;
1652        }
1653        elsif($not_ref) {
1654            push @Data_Stack, { type => '', vals => [ $e1, $e2 ] };
1655            $ok = 0;
1656        }
1657        else {
1658            if( $Refs_Seen{$e1} ) {
1659                return $Refs_Seen{$e1} eq $e2;
1660            }
1661            else {
1662                $Refs_Seen{$e1} = "$e2";
1663            }
1664
1665            my $type = _type($e1);
1666            $type = 'DIFFERENT' unless _type($e2) eq $type;
1667
1668            if( $type eq 'DIFFERENT' ) {
1669                push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
1670                $ok = 0;
1671            }
1672            elsif( $type eq 'ARRAY' ) {
1673                $ok = _eq_array( $e1, $e2 );
1674            }
1675            elsif( $type eq 'HASH' ) {
1676                $ok = _eq_hash( $e1, $e2 );
1677            }
1678            elsif( $type eq 'REF' ) {
1679                push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
1680                $ok = _deep_check( $$e1, $$e2 );
1681                pop @Data_Stack if $ok;
1682            }
1683            elsif( $type eq 'SCALAR' ) {
1684                push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] };
1685                $ok = _deep_check( $$e1, $$e2 );
1686                pop @Data_Stack if $ok;
1687            }
1688            elsif($type) {
1689                push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
1690                $ok = 0;
1691            }
1692            else {
1693                _whoa( 1, "No type in _deep_check" );
1694            }
1695        }
1696    }
1697
1698    return $ok;
1699}
1700
1701sub _whoa {
1702    my( $check, $desc ) = @_;
1703    if($check) {
1704        die <<"WHOA";
1705WHOA!  $desc
1706This should never happen!  Please contact the author immediately!
1707WHOA
1708    }
1709}
1710
1711=item B<eq_hash>
1712
1713  my $is_eq = eq_hash(\%got, \%expected);
1714
1715Determines if the two hashes contain the same keys and values.  This
1716is a deep check.
1717
1718=cut
1719
1720sub eq_hash {
1721    local @Data_Stack = ();
1722    return _deep_check(@_);
1723}
1724
1725sub _eq_hash {
1726    my( $a1, $a2 ) = @_;
1727
1728    if( grep _type($_) ne 'HASH', $a1, $a2 ) {
1729        warn "eq_hash passed a non-hash ref";
1730        return 0;
1731    }
1732
1733    return 1 if $a1 eq $a2;
1734
1735    my $ok = 1;
1736    my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
1737    foreach my $k ( keys %$bigger ) {
1738        my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
1739        my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
1740
1741        next if _equal_nonrefs($e1, $e2);
1742
1743        push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] };
1744        $ok = _deep_check( $e1, $e2 );
1745        pop @Data_Stack if $ok;
1746
1747        last unless $ok;
1748    }
1749
1750    return $ok;
1751}
1752
1753=item B<eq_set>
1754
1755  my $is_eq = eq_set(\@got, \@expected);
1756
1757Similar to C<eq_array()>, except the order of the elements is B<not>
1758important.  This is a deep check, but the irrelevancy of order only
1759applies to the top level.
1760
1761    ok( eq_set(\@got, \@expected) );
1762
1763Is better written:
1764
1765    is_deeply( [sort @got], [sort @expected] );
1766
1767B<NOTE> By historical accident, this is not a true set comparison.
1768While the order of elements does not matter, duplicate elements do.
1769
1770B<NOTE> C<eq_set()> does not know how to deal with references at the top
1771level.  The following is an example of a comparison which might not work:
1772
1773    eq_set([\1, \2], [\2, \1]);
1774
1775L<Test::Deep> contains much better set comparison functions.
1776
1777=cut
1778
1779sub eq_set {
1780    my( $a1, $a2 ) = @_;
1781    return 0 unless @$a1 == @$a2;
1782
1783    no warnings 'uninitialized';
1784
1785    # It really doesn't matter how we sort them, as long as both arrays are
1786    # sorted with the same algorithm.
1787    #
1788    # Ensure that references are not accidentally treated the same as a
1789    # string containing the reference.
1790    #
1791    # Have to inline the sort routine due to a threading/sort bug.
1792    # See [rt.cpan.org 6782]
1793    #
1794    # I don't know how references would be sorted so we just don't sort
1795    # them.  This means eq_set doesn't really work with refs.
1796    return eq_array(
1797        [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ],
1798        [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ],
1799    );
1800}
1801
1802=back
1803
1804
1805=head2 Extending and Embedding Test::More
1806
1807Sometimes the Test::More interface isn't quite enough.  Fortunately,
1808Test::More is built on top of L<Test::Builder> which provides a single,
1809unified backend for any test library to use.  This means two test
1810libraries which both use L<Test::Builder> B<can> be used together in the
1811same program.
1812
1813If you simply want to do a little tweaking of how the tests behave,
1814you can access the underlying L<Test::Builder> object like so:
1815
1816=over 4
1817
1818=item B<builder>
1819
1820    my $test_builder = Test::More->builder;
1821
1822Returns the L<Test::Builder> object underlying Test::More for you to play
1823with.
1824
1825
1826=back
1827
1828
1829=head1 EXIT CODES
1830
1831If all your tests passed, L<Test::Builder> will exit with zero (which is
1832normal).  If anything failed it will exit with how many failed.  If
1833you run less (or more) tests than you planned, the missing (or extras)
1834will be considered failures.  If no tests were ever run L<Test::Builder>
1835will throw a warning and exit with 255.  If the test died, even after
1836having successfully completed all its tests, it will still be
1837considered a failure and will exit with 255.
1838
1839So the exit codes are...
1840
1841    0                   all tests successful
1842    255                 test died or all passed but wrong # of tests run
1843    any other number    how many failed (including missing or extras)
1844
1845If you fail more than 254 tests, it will be reported as 254.
1846
1847B<NOTE>  This behavior may go away in future versions.
1848
1849
1850=head1 COMPATIBILITY
1851
1852Test::More works with Perls as old as 5.8.1.
1853
1854Thread support is not very reliable before 5.10.1, but that's
1855because threads are not very reliable before 5.10.1.
1856
1857Although Test::More has been a core module in versions of Perl since 5.6.2, Test::More has evolved since then, and not all of the features you're used to will be present in the shipped version of Test::More. If you are writing a module, don't forget to indicate in your package metadata the minimum version of Test::More that you require. For instance, if you want to use C<done_testing()> but want your test script to run on Perl 5.10.0, you will need to explicitly require Test::More > 0.88.
1858
1859Key feature milestones include:
1860
1861=over 4
1862
1863=item subtests
1864
1865Subtests were released in Test::More 0.94, which came with Perl 5.12.0. Subtests did not implicitly call C<done_testing()> until 0.96; the first Perl with that fix was Perl 5.14.0 with 0.98.
1866
1867=item C<done_testing()>
1868
1869This was released in Test::More 0.88 and first shipped with Perl in 5.10.1 as part of Test::More 0.92.
1870
1871=item C<cmp_ok()>
1872
1873Although C<cmp_ok()> was introduced in 0.40, 0.86 fixed an important bug to make it safe for overloaded objects; the fixed first shipped with Perl in 5.10.1 as part of Test::More 0.92.
1874
1875=item C<new_ok()> C<note()> and C<explain()>
1876
1877These were was released in Test::More 0.82, and first shipped with Perl in 5.10.1 as part of Test::More 0.92.
1878
1879=back
1880
1881There is a full version history in the Changes file, and the Test::More versions included as core can be found using L<Module::CoreList>:
1882
1883    $ corelist -a Test::More
1884
1885
1886=head1 CAVEATS and NOTES
1887
1888=over 4
1889
1890=item utf8 / "Wide character in print"
1891
1892If you use utf8 or other non-ASCII characters with Test::More you
1893might get a "Wide character in print" warning.  Using
1894C<< binmode STDOUT, ":utf8" >> will not fix it.
1895L<Test::Builder> (which powers
1896Test::More) duplicates STDOUT and STDERR.  So any changes to them,
1897including changing their output disciplines, will not be seen by
1898Test::More.
1899
1900One work around is to apply encodings to STDOUT and STDERR as early
1901as possible and before Test::More (or any other Test module) loads.
1902
1903    use open ':std', ':encoding(utf8)';
1904    use Test::More;
1905
1906A more direct work around is to change the filehandles used by
1907L<Test::Builder>.
1908
1909    my $builder = Test::More->builder;
1910    binmode $builder->output,         ":encoding(utf8)";
1911    binmode $builder->failure_output, ":encoding(utf8)";
1912    binmode $builder->todo_output,    ":encoding(utf8)";
1913
1914
1915=item Overloaded objects
1916
1917String overloaded objects are compared B<as strings> (or in C<cmp_ok()>'s
1918case, strings or numbers as appropriate to the comparison op).  This
1919prevents Test::More from piercing an object's interface allowing
1920better blackbox testing.  So if a function starts returning overloaded
1921objects instead of bare strings your tests won't notice the
1922difference.  This is good.
1923
1924However, it does mean that functions like C<is_deeply()> cannot be used to
1925test the internals of string overloaded objects.  In this case I would
1926suggest L<Test::Deep> which contains more flexible testing functions for
1927complex data structures.
1928
1929
1930=item Threads
1931
1932Test::More will only be aware of threads if C<use threads> has been done
1933I<before> Test::More is loaded.  This is ok:
1934
1935    use threads;
1936    use Test::More;
1937
1938This may cause problems:
1939
1940    use Test::More
1941    use threads;
1942
19435.8.1 and above are supported.  Anything below that has too many bugs.
1944
1945=back
1946
1947
1948=head1 HISTORY
1949
1950This is a case of convergent evolution with Joshua Pritikin's L<Test>
1951module.  I was largely unaware of its existence when I'd first
1952written my own C<ok()> routines.  This module exists because I can't
1953figure out how to easily wedge test names into Test's interface (along
1954with a few other problems).
1955
1956The goal here is to have a testing utility that's simple to learn,
1957quick to use and difficult to trip yourself up with while still
1958providing more flexibility than the existing Test.pm.  As such, the
1959names of the most common routines are kept tiny, special cases and
1960magic side-effects are kept to a minimum.  WYSIWYG.
1961
1962
1963=head1 SEE ALSO
1964
1965=head2
1966
1967=head2 ALTERNATIVES
1968
1969L<Test2::Suite> is the most recent and modern set of tools for testing.
1970
1971L<Test::Simple> if all this confuses you and you just want to write
1972some tests.  You can upgrade to Test::More later (it's forward
1973compatible).
1974
1975L<Test::Legacy> tests written with Test.pm, the original testing
1976module, do not play well with other testing libraries.  Test::Legacy
1977emulates the Test.pm interface and does play well with others.
1978
1979=head2 ADDITIONAL LIBRARIES
1980
1981L<Test::Differences> for more ways to test complex data structures.
1982And it plays well with Test::More.
1983
1984L<Test::Class> is like xUnit but more perlish.
1985
1986L<Test::Deep> gives you more powerful complex data structure testing.
1987
1988L<Test::Inline> shows the idea of embedded testing.
1989
1990L<Mock::Quick> The ultimate mocking library. Easily spawn objects defined on
1991the fly. Can also override, block, or reimplement packages as needed.
1992
1993L<Test::FixtureBuilder> Quickly define fixture data for unit tests.
1994
1995=head2 OTHER COMPONENTS
1996
1997L<Test::Harness> is the test runner and output interpreter for Perl.
1998It's the thing that powers C<make test> and where the C<prove> utility
1999comes from.
2000
2001=head2 BUNDLES
2002
2003L<Test::Most> Most commonly needed test functions and features.
2004
2005=head1 AUTHORS
2006
2007Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration
2008from Joshua Pritikin's Test module and lots of help from Barrie
2009Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and
2010the perl-qa gang.
2011
2012=head1 MAINTAINERS
2013
2014=over 4
2015
2016=item Chad Granum E<lt>exodist@cpan.orgE<gt>
2017
2018=back
2019
2020
2021=head1 BUGS
2022
2023See L<https://github.com/Test-More/test-more/issues> to report and view bugs.
2024
2025
2026=head1 SOURCE
2027
2028The source code repository for Test::More can be found at
2029L<https://github.com/Test-More/test-more/>.
2030
2031
2032=head1 COPYRIGHT
2033
2034Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
2035
2036This program is free software; you can redistribute it and/or
2037modify it under the same terms as Perl itself.
2038
2039See L<https://dev.perl.org/licenses/>
2040
2041=cut
2042
20431;
2044