← Index
NYTProf Performance Profile   « line view »
For t/optimization.t
  Run on Thu Jan 8 22:47:42 2015
Reported on Thu Jan 8 22:48:05 2015

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