← Index
NYTProf Performance Profile   « block view • line view • sub view »
For t/app_dpath.t
  Run on Tue Jun 5 15:25:28 2012
Reported on Tue Jun 5 15:26:02 2012

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