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