← Index
NYTProf Performance Profile   « line view »
For t/bug-md-11.t
  Run on Fri Mar 8 13:27:24 2024
Reported on Fri Mar 8 13:30:22 2024

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