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