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

Filename/home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1/Test/Builder.pm
StatementsExecuted 4306 statements in 77.4ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
20225.73ms34.2msTest::Builder::::okTest::Builder::ok
82315.26ms7.09msTest::Builder::::_tryTest::Builder::_try
63214.00ms4.73msTest::Builder::::callerTest::Builder::caller
1112.72ms5.61msTest::Builder::::BEGIN@19Test::Builder::BEGIN@19
40112.69ms9.80msTest::Builder::::_unoverloadTest::Builder::_unoverload
22212.47ms5.84msTest::Builder::::_print_to_fhTest::Builder::_print_to_fh
22112.04ms2.04msTest::Builder::::CORE:printTest::Builder::CORE:print (opcode)
61211.88ms6.31msTest::Builder::::find_TODOTest::Builder::find_TODO
40111.45ms3.40msTest::Builder::::_is_objectTest::Builder::_is_object
20111.08ms4.07msTest::Builder::::todoTest::Builder::todo
2111.08ms1.26msTest::Builder::::__ANON__[:1906]Test::Builder::__ANON__[:1906]
42211.07ms1.07msTest::Builder::::CORE:matchTest::Builder::CORE:match (opcode)
211859µs4.42msTest::Builder::::cmp_okTest::Builder::cmp_ok
4131833µs4.16msTest::Builder::::in_todoTest::Builder::in_todo
4021828µs10.6msTest::Builder::::_unoverload_strTest::Builder::_unoverload_str
2121815µs7.09msTest::Builder::::_printTest::Builder::_print
6311728µs728µsTest::Builder::::levelTest::Builder::level
2221661µs699µsTest::Builder::::outputTest::Builder::output
4331659µs659µsTest::Builder::::CORE:substTest::Builder::CORE:subst (opcode)
2211623µs623µsTest::Builder::::_indentTest::Builder::_indent
2011543µs784µsTest::Builder::::_check_is_passing_planTest::Builder::_check_is_passing_plan
2121383µs383µsTest::Builder::::__ANON__[:67]Test::Builder::__ANON__[:67]
2341356µs356µsTest::Builder::::__ANON__[:66]Test::Builder::__ANON__[:66]
4011341µs341µsTest::Builder::::__ANON__[:871]Test::Builder::__ANON__[:871]
2011262µs262µsTest::Builder::::use_numbersTest::Builder::use_numbers
111254µs295µsTest::Builder::::_endingTest::Builder::_ending
2011241µs241µsTest::Builder::::has_planTest::Builder::has_plan
4011232µs232µsTest::Builder::::__ANON__[:887]Test::Builder::__ANON__[:887]
733209µs2.60msTest::Builder::::newTest::Builder::new
111155µs449µsTest::Builder::::done_testingTest::Builder::done_testing
111151µs2.35msTest::Builder::::resetTest::Builder::reset
211133µs4.55msTest::Builder::::isnt_eqTest::Builder::isnt_eq
221129µs129µsTest::Builder::::CORE:openTest::Builder::CORE:open (opcode)
111114µs361µsTest::Builder::::_print_commentTest::Builder::_print_comment
441104µs134µsTest::Builder::::_autoflushTest::Builder::_autoflush
111101µs1.74msTest::Builder::::_open_testhandlesTest::Builder::_open_testhandles
21196µs145µsTest::Builder::::_apply_layersTest::Builder::_apply_layers
11192µs108µsTest::Builder::::BEGIN@18Test::Builder::BEGIN@18
22187µs1.51msTest::Builder::::_copy_io_layersTest::Builder::_copy_io_layers
11185µs85µsTest::Builder::::BEGIN@3Test::Builder::BEGIN@3
11181µs2.17msTest::Builder::::_dup_stdhandlesTest::Builder::_dup_stdhandles
11172µs637µsTest::Builder::::diagTest::Builder::diag
11164µs205µsTest::Builder::::_diag_fhTest::Builder::_diag_fh
11162µs133µsTest::Builder::::BEGIN@916Test::Builder::BEGIN@916
33157µs84µsTest::Builder::::_new_fhTest::Builder::_new_fh
11154µs115µsTest::Builder::::BEGIN@1221Test::Builder::BEGIN@1221
11154µs61µsTest::Builder::::current_testTest::Builder::current_test
22154µs77µsTest::Builder::::failure_outputTest::Builder::failure_output
11154µs209µsTest::Builder::::reset_outputsTest::Builder::reset_outputs
21149µs49µsTest::Builder::::CORE:binmodeTest::Builder::CORE:binmode (opcode)
11147µs120µsTest::Builder::::BEGIN@2181Test::Builder::BEGIN@2181
11147µs2.39msTest::Builder::::createTest::Builder::create
22144µs44µsTest::Builder::::__ANON__[:1598]Test::Builder::__ANON__[:1598]
11144µs339µsTest::Builder::::ENDTest::Builder::END
11142µs113µsTest::Builder::::BEGIN@1600Test::Builder::BEGIN@1600
11141µs213µsTest::Builder::::_output_planTest::Builder::_output_plan
82130µs30µsTest::Builder::::CORE:selectTest::Builder::CORE:select (opcode)
31127µs27µsTest::Builder::::is_fhTest::Builder::is_fh
11127µs37µsTest::Builder::::BEGIN@4Test::Builder::BEGIN@4
11127µs49µsTest::Builder::::BEGIN@5Test::Builder::BEGIN@5
11122µs44µsTest::Builder::::todo_outputTest::Builder::todo_output
11120µs20µsTest::Builder::::expected_testsTest::Builder::expected_tests
11119µs19µsTest::Builder::::BEGIN@10Test::Builder::BEGIN@10
11117µs17µsTest::Builder::::exported_toTest::Builder::exported_to
11115µs15µsTest::Builder::::is_passingTest::Builder::is_passing
11111µs11µsTest::Builder::::_my_exitTest::Builder::_my_exit
1119µs9µsTest::Builder::::planTest::Builder::plan
0000s0sTest::Builder::::BAIL_OUTTest::Builder::BAIL_OUT
0000s0sTest::Builder::::DESTROYTest::Builder::DESTROY
0000s0sTest::Builder::::__ANON__[:1712]Test::Builder::__ANON__[:1712]
0000s0sTest::Builder::::__ANON__[:237]Test::Builder::__ANON__[:237]
0000s0sTest::Builder::::__ANON__[:61]Test::Builder::__ANON__[:61]
0000s0sTest::Builder::::_caller_contextTest::Builder::_caller_context
0000s0sTest::Builder::::_cmp_diagTest::Builder::_cmp_diag
0000s0sTest::Builder::::_diag_fmtTest::Builder::_diag_fmt
0000s0sTest::Builder::::_is_diagTest::Builder::_is_diag
0000s0sTest::Builder::::_is_dualvarTest::Builder::_is_dualvar
0000s0sTest::Builder::::_is_qrTest::Builder::_is_qr
0000s0sTest::Builder::::_isnt_diagTest::Builder::_isnt_diag
0000s0sTest::Builder::::_message_at_callerTest::Builder::_message_at_caller
0000s0sTest::Builder::::_plan_handledTest::Builder::_plan_handled
0000s0sTest::Builder::::_plan_testsTest::Builder::_plan_tests
0000s0sTest::Builder::::_regex_okTest::Builder::_regex_ok
0000s0sTest::Builder::::_sanity_checkTest::Builder::_sanity_check
0000s0sTest::Builder::::_unoverload_numTest::Builder::_unoverload_num
0000s0sTest::Builder::::_whoaTest::Builder::_whoa
0000s0sTest::Builder::::carpTest::Builder::carp
0000s0sTest::Builder::::childTest::Builder::child
0000s0sTest::Builder::::croakTest::Builder::croak
0000s0sTest::Builder::::detailsTest::Builder::details
0000s0sTest::Builder::::explainTest::Builder::explain
0000s0sTest::Builder::::finalizeTest::Builder::finalize
0000s0sTest::Builder::::is_eqTest::Builder::is_eq
0000s0sTest::Builder::::is_numTest::Builder::is_num
0000s0sTest::Builder::::isnt_numTest::Builder::isnt_num
0000s0sTest::Builder::::likeTest::Builder::like
0000s0sTest::Builder::::maybe_regexTest::Builder::maybe_regex
0000s0sTest::Builder::::nameTest::Builder::name
0000s0sTest::Builder::::no_planTest::Builder::no_plan
0000s0sTest::Builder::::noteTest::Builder::note
0000s0sTest::Builder::::parentTest::Builder::parent
0000s0sTest::Builder::::skipTest::Builder::skip
0000s0sTest::Builder::::skip_allTest::Builder::skip_all
0000s0sTest::Builder::::subtestTest::Builder::subtest
0000s0sTest::Builder::::summaryTest::Builder::summary
0000s0sTest::Builder::::todo_endTest::Builder::todo_end
0000s0sTest::Builder::::todo_skipTest::Builder::todo_skip
0000s0sTest::Builder::::todo_startTest::Builder::todo_start
0000s0sTest::Builder::::unlikeTest::Builder::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::Builder;
2
32180µs185µs
# spent 85µs within Test::Builder::BEGIN@3 which was called: # once (85µs+0s) by Test::Builder::Module::BEGIN@5 at line 3
use 5.006;
# spent 85µs making 1 call to Test::Builder::BEGIN@3
4287µs247µs
# spent 37µs (27+10) within Test::Builder::BEGIN@4 which was called: # once (27µs+10µs) by Test::Builder::Module::BEGIN@5 at line 4
use strict;
# spent 37µs making 1 call to Test::Builder::BEGIN@4 # spent 10µs making 1 call to strict::import
52243µs272µs
# spent 49µs (27+23) within Test::Builder::BEGIN@5 which was called: # once (27µs+23µs) by Test::Builder::Module::BEGIN@5 at line 5
use warnings;
# spent 49µs making 1 call to Test::Builder::BEGIN@5 # spent 23µs making 1 call to warnings::import
6
714µsour $VERSION = '0.98';
8185µs$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
# spent 13µs executing statements in string eval
9
10
# spent 19µs within Test::Builder::BEGIN@10 which was called: # once (19µs+0s) by Test::Builder::Module::BEGIN@5 at line 14
BEGIN {
11120µs if( $] < 5.008 ) {
12 require Test::Builder::IO::Scalar;
13 }
14189µs119µs}
# spent 19µs making 1 call to Test::Builder::BEGIN@10
15
16
17# Make Test::Builder thread-safe for ithreads.
18
# spent 108µs (92+17) within Test::Builder::BEGIN@18 which was called: # once (92µs+17µs) by Test::Builder::Module::BEGIN@5 at line 69
BEGIN {
1921.39ms25.67ms
# spent 5.61ms (2.72+2.89) within Test::Builder::BEGIN@19 which was called: # once (2.72ms+2.89ms) by Test::Builder::Module::BEGIN@5 at line 19
use Config;
# spent 5.61ms making 1 call to Test::Builder::BEGIN@19 # spent 54µs making 1 call to Config::import
20 # Load threads::shared when threads are turned on.
21 # 5.8.0's threads are so busted we no longer support them.
22375µs117µs if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
# spent 17µs making 1 call to Config::FETCH
23 require threads::shared;
24
25 # Hack around YET ANOTHER threads::shared bug. It would
26 # occasionally forget the contents of the variable when sharing it.
27 # So we first copy the data, then share, then put our copy back.
28 *share = sub (\[$@%]) {
29 my $type = ref $_[0];
30 my $data;
31
32 if( $type eq 'HASH' ) {
33 %$data = %{ $_[0] };
34 }
35 elsif( $type eq 'ARRAY' ) {
36 @$data = @{ $_[0] };
37 }
38 elsif( $type eq 'SCALAR' ) {
39 $$data = ${ $_[0] };
40 }
41 else {
42 die( "Unknown type: " . $type );
43 }
44
45 $_[0] = &threads::shared::share( $_[0] );
46
47 if( $type eq 'HASH' ) {
48 %{ $_[0] } = %$data;
49 }
50 elsif( $type eq 'ARRAY' ) {
51 @{ $_[0] } = @$data;
52 }
53 elsif( $type eq 'SCALAR' ) {
54 ${ $_[0] } = $$data;
55 }
56 else {
57 die( "Unknown type: " . $type );
58 }
59
60 return $_[0];
61 };
62 }
63 # 5.8.0's threads::shared is busted when threads are off
64 # and earlier Perls just don't have that module at all.
65 else {
6623353µs
# spent 356µs within Test::Builder::__ANON__[/home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1/Test/Builder.pm:66] which was called 23 times, avg 15µs/call: # 20 times (335µs+0s) by Test::Builder::ok at line 795, avg 17µs/call # once (9µs+0s) by Test::Builder::_ending at line 2430 # once (7µs+0s) by Test::Builder::reset at line 418 # once (6µs+0s) by Test::Builder::reset at line 420
*share = sub { return $_[0] };
6721309µs
# spent 383µs within Test::Builder::__ANON__[/home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1/Test/Builder.pm:67] which was called 21 times, avg 18µs/call: # 20 times (376µs+0s) by Test::Builder::ok at line 775, avg 19µs/call # once (7µs+0s) by Test::Builder::current_test at line 1997
*lock = sub { 0 };
68 }
69111.2ms1108µs}
# spent 108µs making 1 call to Test::Builder::BEGIN@18
70
71=head1 NAME
72
73Test::Builder - Backend for building test libraries
74
75=head1 SYNOPSIS
76
77 package My::Test::Module;
78 use base 'Test::Builder::Module';
79
80 my $CLASS = __PACKAGE__;
81
82 sub ok {
83 my($test, $name) = @_;
84 my $tb = $CLASS->builder;
85
86 $tb->ok($test, $name);
87 }
88
89
90=head1 DESCRIPTION
91
92Test::Simple and Test::More have proven to be popular testing modules,
93but they're not always flexible enough. Test::Builder provides a
94building block upon which to write your own test libraries I<which can
95work together>.
96
97=head2 Construction
98
99=over 4
100
101=item B<new>
102
103 my $Test = Test::Builder->new;
104
105Returns a Test::Builder object representing the current state of the
106test.
107
108Since you only run one test per program C<new> always returns the same
109Test::Builder object. No matter how many times you call C<new()>, you're
110getting the same object. This is called a singleton. This is done so that
111multiple modules share such global information as the test counter and
112where test output is going.
113
114If you want a completely new Test::Builder object different from the
115singleton, use C<create>.
116
117=cut
118
119122µs12.43msour $Test = Test::Builder->new;
# spent 2.43ms making 1 call to Test::Builder::new
120
121
# spent 2.60ms (209µs+2.39) within Test::Builder::new which was called 7 times, avg 372µs/call: # 5 times (148µs+0s) by Test::Builder::Module::builder at line 170 of Test/Builder/Module.pm, avg 30µs/call # once (39µs+2.39ms) by Test::Builder::Module::BEGIN@5 at line 119 # once (23µs+0s) by main::BEGIN@8 at line 19 of Test/Deep.pm
sub new {
12221278µs my($class) = shift;
12312.39ms $Test ||= $class->create;
# spent 2.39ms making 1 call to Test::Builder::create
124 return $Test;
125}
126
127=item B<create>
128
129 my $Test = Test::Builder->create;
130
131Ok, so there can be more than one Test::Builder object and this is how
132you get it. You might use this instead of C<new()> if you're testing
133a Test::Builder based module, but otherwise you probably want C<new>.
134
135B<NOTE>: the implementation is not complete. C<level>, for example, is
136still shared amongst B<all> Test::Builder objects, even ones created using
137this method. Also, the method name may change in the future.
138
139=cut
140
141
# spent 2.39ms (47µs+2.35) within Test::Builder::create which was called: # once (47µs+2.35ms) by Test::Builder::new at line 123
sub create {
142452µs my $class = shift;
143
144 my $self = bless {}, $class;
14512.35ms $self->reset;
# spent 2.35ms making 1 call to Test::Builder::reset
146
147 return $self;
148}
149
150=item B<child>
151
152 my $child = $builder->child($name_of_child);
153 $child->plan( tests => 4 );
154 $child->ok(some_code());
155 ...
156 $child->finalize;
157
158Returns a new instance of C<Test::Builder>. Any output from this child will
159be indented four spaces more than the parent's indentation. When done, the
160C<finalize> method I<must> be called explicitly.
161
162Trying to create a new child with a previous child still active (i.e.,
163C<finalize> not called) will C<croak>.
164
165Trying to run a test when you have an open child will also C<croak> and cause
166the test suite to fail.
167
168=cut
169
170sub child {
171 my( $self, $name ) = @_;
172
173 if( $self->{Child_Name} ) {
174 $self->croak("You already have a child named ($self->{Child_Name}) running");
175 }
176
177 my $parent_in_todo = $self->in_todo;
178
179 # Clear $TODO for the child.
180 my $orig_TODO = $self->find_TODO(undef, 1, undef);
181
182 my $child = bless {}, ref $self;
183 $child->reset;
184
185 # Add to our indentation
186 $child->_indent( $self->_indent . ' ' );
187
188 $child->{$_} = $self->{$_} foreach qw{Out_FH Todo_FH Fail_FH};
189 if ($parent_in_todo) {
190 $child->{Fail_FH} = $self->{Todo_FH};
191 }
192
193 # This will be reset in finalize. We do this here lest one child failure
194 # cause all children to fail.
195 $child->{Child_Error} = $?;
196 $? = 0;
197 $child->{Parent} = $self;
198 $child->{Parent_TODO} = $orig_TODO;
199 $child->{Name} = $name || "Child of " . $self->name;
200 $self->{Child_Name} = $child->name;
201 return $child;
202}
203
204
205=item B<subtest>
206
207 $builder->subtest($name, \&subtests);
208
209See documentation of C<subtest> in Test::More.
210
211=cut
212
213sub subtest {
214 my $self = shift;
215 my($name, $subtests) = @_;
216
217 if ('CODE' ne ref $subtests) {
218 $self->croak("subtest()'s second argument must be a code ref");
219 }
220
221 # Turn the child into the parent so anyone who has stored a copy of
222 # the Test::Builder singleton will get the child.
223 my($error, $child, %parent);
224 {
225 # child() calls reset() which sets $Level to 1, so we localize
226 # $Level first to limit the scope of the reset to the subtest.
227 local $Test::Builder::Level = $Test::Builder::Level + 1;
228
229 $child = $self->child($name);
230 %parent = %$self;
231 %$self = %$child;
232
233 my $run_the_subtests = sub {
234 $subtests->();
235 $self->done_testing unless $self->_plan_handled;
236 1;
237 };
238
239 if( !eval { $run_the_subtests->() } ) {
240 $error = $@;
241 }
242 }
243
244 # Restore the parent and the copied child.
245 %$child = %$self;
246 %$self = %parent;
247
248 # Restore the parent's $TODO
249 $self->find_TODO(undef, 1, $child->{Parent_TODO});
250
251 # Die *after* we restore the parent.
252 die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
253
254 local $Test::Builder::Level = $Test::Builder::Level + 1;
255 return $child->finalize;
256}
257
258=begin _private
259
260=item B<_plan_handled>
261
262 if ( $Test->_plan_handled ) { ... }
263
264Returns true if the developer has explicitly handled the plan via:
265
266=over 4
267
268=item * Explicitly setting the number of tests
269
270=item * Setting 'no_plan'
271
272=item * Set 'skip_all'.
273
274=back
275
276This is currently used in subtests when we implicitly call C<< $Test->done_testing >>
277if the developer has not set a plan.
278
279=end _private
280
281=cut
282
283sub _plan_handled {
284 my $self = shift;
285 return $self->{Have_Plan} || $self->{No_Plan} || $self->{Skip_All};
286}
287
288
289=item B<finalize>
290
291 my $ok = $child->finalize;
292
293When your child is done running tests, you must call C<finalize> to clean up
294and tell the parent your pass/fail status.
295
296Calling finalize on a child with open children will C<croak>.
297
298If the child falls out of scope before C<finalize> is called, a failure
299diagnostic will be issued and the child is considered to have failed.
300
301No attempt to call methods on a child after C<finalize> is called is
302guaranteed to succeed.
303
304Calling this on the root builder is a no-op.
305
306=cut
307
308sub finalize {
309 my $self = shift;
310
311 return unless $self->parent;
312 if( $self->{Child_Name} ) {
313 $self->croak("Can't call finalize() with child ($self->{Child_Name}) active");
314 }
315
316 local $? = 0; # don't fail if $subtests happened to set $? nonzero
317 $self->_ending;
318
319 # XXX This will only be necessary for TAP envelopes (we think)
320 #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );
321
322 local $Test::Builder::Level = $Test::Builder::Level + 1;
323 my $ok = 1;
324 $self->parent->{Child_Name} = undef;
325 if ( $self->{Skip_All} ) {
326 $self->parent->skip($self->{Skip_All});
327 }
328 elsif ( not @{ $self->{Test_Results} } ) {
329 $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name );
330 }
331 else {
332 $self->parent->ok( $self->is_passing, $self->name );
333 }
334 $? = $self->{Child_Error};
335 delete $self->{Parent};
336
337 return $self->is_passing;
338}
339
340
# spent 623µs within Test::Builder::_indent which was called 22 times, avg 28µs/call: # 22 times (623µs+0s) by Test::Builder::_print_to_fh at line 1748, avg 28µs/call
sub _indent {
34166518µs my $self = shift;
342
343 if( @_ ) {
344 $self->{Indent} = shift;
345 }
346
347 return $self->{Indent};
348}
349
350=item B<parent>
351
352 if ( my $parent = $builder->parent ) {
353 ...
354 }
355
356Returns the parent C<Test::Builder> instance, if any. Only used with child
357builders for nested TAP.
358
359=cut
360
361sub parent { shift->{Parent} }
362
363=item B<name>
364
365 diag $builder->name;
366
367Returns the name of the current builder. Top level builders default to C<$0>
368(the name of the executable). Child builders are named via the C<child>
369method. If no name is supplied, will be named "Child of $parent->name".
370
371=cut
372
373sub name { shift->{Name} }
374
375sub DESTROY {
376 my $self = shift;
377 if ( $self->parent and $$ == $self->{Original_Pid} ) {
378 my $name = $self->name;
379 $self->diag(<<"FAIL");
380Child ($name) exited without calling finalize()
381FAIL
382 $self->parent->{In_Destroy} = 1;
383 $self->parent->ok(0, $name);
384 }
385}
386
387=item B<reset>
388
389 $Test->reset;
390
391Reinitializes the Test::Builder singleton to its original state.
392Mostly useful for tests run in persistent environments where the same
393test might be run multiple times in the same process.
394
395=cut
396
39711µsour $Level;
398
399
# spent 2.35ms (151µs+2.20) within Test::Builder::reset which was called: # once (151µs+2.20ms) by Test::Builder::create at line 145
sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
40027110µs my($self) = @_;
401
402 # We leave this a global because it has to be localized and localizing
403 # hash keys is just asking for pain. Also, it was documented.
404 $Level = 1;
405
406 $self->{Name} = $0;
407115µs $self->is_passing(1);
# spent 15µs making 1 call to Test::Builder::is_passing
408 $self->{Ending} = 0;
409 $self->{Have_Plan} = 0;
410 $self->{No_Plan} = 0;
411 $self->{Have_Output_Plan} = 0;
412 $self->{Done_Testing} = 0;
413
414 $self->{Original_Pid} = $$;
415 $self->{Child_Name} = undef;
416 $self->{Indent} ||= '';
417
41817µs share( $self->{Curr_Test} );
# spent 7µs making 1 call to Test::Builder::__ANON__[Test/Builder.pm:66]
419 $self->{Curr_Test} = 0;
42016µs $self->{Test_Results} = &share( [] );
# spent 6µs making 1 call to Test::Builder::__ANON__[Test/Builder.pm:66]
421
422 $self->{Exported_To} = undef;
423 $self->{Expected_Tests} = 0;
424
425 $self->{Skip_All} = 0;
426
427 $self->{Use_Nums} = 1;
428
429 $self->{No_Header} = 0;
430 $self->{No_Ending} = 0;
431
432 $self->{Todo} = undef;
433 $self->{Todo_Stack} = [];
434 $self->{Start_Todo} = 0;
435 $self->{Opened_Testhandles} = 0;
436
43712.17ms $self->_dup_stdhandles;
# spent 2.17ms making 1 call to Test::Builder::_dup_stdhandles
438
439 return;
440}
441
442=back
443
444=head2 Setting up tests
445
446These methods are for setting up tests and declaring how many there
447are. You usually only want to call one of these methods.
448
449=over 4
450
451=item B<plan>
452
453 $Test->plan('no_plan');
454 $Test->plan( skip_all => $reason );
455 $Test->plan( tests => $num_tests );
456
457A convenient way to set up your tests. Call this and Test::Builder
458will print the appropriate headers and take the appropriate actions.
459
460If you call C<plan()>, don't call any of the other methods below.
461
462If a child calls "skip_all" in the plan, a C<Test::Builder::Exception> is
463thrown. Trap this error, call C<finalize()> and don't run any more tests on
464the child.
465
466 my $child = $Test->child('some child');
467 eval { $child->plan( $condition ? ( skip_all => $reason ) : ( tests => 3 ) ) };
468 if ( eval { $@->isa('Test::Builder::Exception') } ) {
469 $child->finalize;
470 return;
471 }
472 # run your tests
473
474=cut
475
476112µsmy %plan_cmds = (
477 no_plan => \&no_plan,
478 skip_all => \&skip_all,
479 tests => \&_plan_tests,
480);
481
482
# spent 9µs within Test::Builder::plan which was called: # once (9µs+0s) by Test::Builder::Module::import at line 91 of Test/Builder/Module.pm
sub plan {
483218µs my( $self, $cmd, $arg ) = @_;
484
485 return unless $cmd;
486
487 local $Level = $Level + 1;
488
489 $self->croak("You tried to plan twice") if $self->{Have_Plan};
490
491 if( my $method = $plan_cmds{$cmd} ) {
492 local $Level = $Level + 1;
493 $self->$method($arg);
494 }
495 else {
496 my @args = grep { defined } ( $cmd, $arg );
497 $self->croak("plan() doesn't understand @args");
498 }
499
500 return 1;
501}
502
503
504sub _plan_tests {
505 my($self, $arg) = @_;
506
507 if($arg) {
508 local $Level = $Level + 1;
509 return $self->expected_tests($arg);
510 }
511 elsif( !defined $arg ) {
512 $self->croak("Got an undefined number of tests");
513 }
514 else {
515 $self->croak("You said to run 0 tests");
516 }
517
518 return;
519}
520
521=item B<expected_tests>
522
523 my $max = $Test->expected_tests;
524 $Test->expected_tests($max);
525
526Gets/sets the number of tests we expect this test to run and prints out
527the appropriate headers.
528
529=cut
530
531
# spent 20µs within Test::Builder::expected_tests which was called: # once (20µs+0s) by Test::Builder::done_testing at line 659
sub expected_tests {
532433µs my $self = shift;
533 my($max) = @_;
534
535 if(@_) {
536 $self->croak("Number of tests must be a positive integer. You gave it '$max'")
537 unless $max =~ /^\+?\d+$/;
538
539 $self->{Expected_Tests} = $max;
540 $self->{Have_Plan} = 1;
541
542 $self->_output_plan($max) unless $self->no_header;
543 }
544 return $self->{Expected_Tests};
545}
546
547=item B<no_plan>
548
549 $Test->no_plan;
550
551Declares that this test will run an indeterminate number of tests.
552
553=cut
554
555sub no_plan {
556 my($self, $arg) = @_;
557
558 $self->carp("no_plan takes no arguments") if $arg;
559
560 $self->{No_Plan} = 1;
561 $self->{Have_Plan} = 1;
562
563 return 1;
564}
565
566=begin private
567
568=item B<_output_plan>
569
570 $tb->_output_plan($max);
571 $tb->_output_plan($max, $directive);
572 $tb->_output_plan($max, $directive => $reason);
573
574Handles displaying the test plan.
575
576If a C<$directive> and/or C<$reason> are given they will be output with the
577plan. So here's what skipping all tests looks like:
578
579 $tb->_output_plan(0, "SKIP", "Because I said so");
580
581It sets C<< $tb->{Have_Output_Plan} >> and will croak if the plan was already
582output.
583
584=end private
585
586=cut
587
588
# spent 213µs (41+172) within Test::Builder::_output_plan which was called: # once (41µs+172µs) by Test::Builder::done_testing at line 667
sub _output_plan {
589850µs my($self, $max, $directive, $reason) = @_;
590
591 $self->carp("The plan was already output") if $self->{Have_Output_Plan};
592
593 my $plan = "1..$max";
594 $plan .= " # $directive" if defined $directive;
595 $plan .= " $reason" if defined $reason;
596
5971172µs $self->_print("$plan\n");
# spent 172µs making 1 call to Test::Builder::_print
598
599 $self->{Have_Output_Plan} = 1;
600
601 return;
602}
603
604
605=item B<done_testing>
606
607 $Test->done_testing();
608 $Test->done_testing($num_tests);
609
610Declares that you are done testing, no more tests will be run after this point.
611
612If a plan has not yet been output, it will do so.
613
614$num_tests is the number of tests you planned to run. If a numbered
615plan was already declared, and if this contradicts, a failing test
616will be run to reflect the planning mistake. If C<no_plan> was declared,
617this will override.
618
619If C<done_testing()> is called twice, the second call will issue a
620failing test.
621
622If C<$num_tests> is omitted, the number of tests run will be used, like
623no_plan.
624
625C<done_testing()> is, in effect, used when you'd want to use C<no_plan>, but
626safer. You'd use it like so:
627
628 $Test->ok($a == $b);
629 $Test->done_testing();
630
631Or to plan a variable number of tests:
632
633 for my $test (@tests) {
634 $Test->ok($test);
635 }
636 $Test->done_testing(@tests);
637
638=cut
639
640
# spent 449µs (155+294) within Test::Builder::done_testing which was called: # once (155µs+294µs) by Test::More::done_testing at line 221 of Test/More.pm
sub done_testing {
64112115µs my($self, $num_tests) = @_;
642
643 # If done_testing() specified the number of tests, shut off no_plan.
644 if( defined $num_tests ) {
645 $self->{No_Plan} = 0;
646 }
647 else {
648161µs $num_tests = $self->current_test;
# spent 61µs making 1 call to Test::Builder::current_test
649 }
650
651 if( $self->{Done_Testing} ) {
652 my($file, $line) = @{$self->{Done_Testing}}[1,2];
653 $self->ok(0, "done_testing() was already called at $file line $line");
654 return;
655 }
656
657 $self->{Done_Testing} = [caller];
658
659120µs if( $self->expected_tests && $num_tests != $self->expected_tests ) {
# spent 20µs making 1 call to Test::Builder::expected_tests
660 $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
661 "but done_testing() expects $num_tests");
662 }
663 else {
664 $self->{Expected_Tests} = $num_tests;
665 }
666
6671213µs $self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
# spent 213µs making 1 call to Test::Builder::_output_plan
668
669 $self->{Have_Plan} = 1;
670
671 # The wrong number of tests were run
672 $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test};
673
674 # No tests were run
675 $self->is_passing(0) if $self->{Curr_Test} == 0;
676
677 return 1;
678}
679
680
681=item B<has_plan>
682
683 $plan = $Test->has_plan
684
685Find out whether a plan has been defined. C<$plan> is either C<undef> (no plan
686has been set), C<no_plan> (indeterminate # of tests) or an integer (the number
687of expected tests).
688
689=cut
690
691
# spent 241µs within Test::Builder::has_plan which was called 20 times, avg 12µs/call: # 20 times (241µs+0s) by Test::Builder::_check_is_passing_plan at line 860, avg 12µs/call
sub has_plan {
69280330µs my $self = shift;
693
694 return( $self->{Expected_Tests} ) if $self->{Expected_Tests};
695 return('no_plan') if $self->{No_Plan};
696 return(undef);
697}
698
699=item B<skip_all>
700
701 $Test->skip_all;
702 $Test->skip_all($reason);
703
704Skips all the tests, using the given C<$reason>. Exits immediately with 0.
705
706=cut
707
708sub skip_all {
709 my( $self, $reason ) = @_;
710
711 $self->{Skip_All} = $self->parent ? $reason : 1;
712
713 $self->_output_plan(0, "SKIP", $reason) unless $self->no_header;
714 if ( $self->parent ) {
715 die bless {} => 'Test::Builder::Exception';
716 }
717 exit(0);
718}
719
720=item B<exported_to>
721
722 my $pack = $Test->exported_to;
723 $Test->exported_to($pack);
724
725Tells Test::Builder what package you exported your functions to.
726
727This method isn't terribly useful since modules which share the same
728Test::Builder object might get exported to different packages and only
729the last one will be honored.
730
731=cut
732
733
# spent 17µs within Test::Builder::exported_to which was called: # once (17µs+0s) by Test::Builder::Module::import at line 86 of Test/Builder/Module.pm
sub exported_to {
734325µs my( $self, $pack ) = @_;
735
736 if( defined $pack ) {
737 $self->{Exported_To} = $pack;
738 }
739 return $self->{Exported_To};
740}
741
742=back
743
744=head2 Running tests
745
746These actually run the tests, analogous to the functions in Test::More.
747
748They all return true if the test passed, false if the test failed.
749
750C<$name> is always optional.
751
752=over 4
753
754=item B<ok>
755
756 $Test->ok($test, $name);
757
758Your basic test. Pass if C<$test> is true, fail if $test is false. Just
759like Test::Simple's C<ok()>.
760
761=cut
762
763
# spent 34.2ms (5.73+28.4) within Test::Builder::ok which was called 20 times, avg 1.71ms/call: # 18 times (5.14ms+25.8ms) by Test::Deep::cmp_deeply at line 134 of Test/Deep.pm, avg 1.72ms/call # 2 times (590µs+2.67ms) by Test::Builder::cmp_ok at line 1129, avg 1.63ms/call
sub ok {
7646206.99ms my( $self, $test, $name ) = @_;
765
766 if ( $self->{Child_Name} and not $self->{In_Destroy} ) {
767 $name = 'unnamed test' unless defined $name;
768 $self->is_passing(0);
769 $self->croak("Cannot run test ($name) with active children");
770 }
771 # $test might contain an object which we don't want to accidentally
772 # store, so we turn it into a boolean.
773 $test = $test ? 1 : 0;
774
77520376µs lock $self->{Curr_Test};
# spent 376µs making 20 calls to Test::Builder::__ANON__[Test/Builder.pm:67], avg 19µs/call
776 $self->{Curr_Test}++;
777
778 # In case $name is a string overloaded object, force it to stringify.
779207.02ms $self->_unoverload_str( \$name );
# spent 7.02ms making 20 calls to Test::Builder::_unoverload_str, avg 351µs/call
780
78120809µs $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
# spent 809µs making 20 calls to Test::Builder::CORE:match, avg 40µs/call
782 You named your test '$name'. You shouldn't use numbers for your test names.
783 Very confusing.
784ERR
785
786 # Capture the value of $TODO for the rest of this ok() call
787 # so it can more easily be found by other routines.
788204.07ms my $todo = $self->todo();
# spent 4.07ms making 20 calls to Test::Builder::todo, avg 203µs/call
789201.87ms my $in_todo = $self->in_todo;
# spent 1.87ms making 20 calls to Test::Builder::in_todo, avg 93µs/call
790 local $self->{Todo} = $todo if $in_todo;
791
792203.61ms $self->_unoverload_str( \$todo );
# spent 3.61ms making 20 calls to Test::Builder::_unoverload_str, avg 180µs/call
793
794 my $out;
79520335µs my $result = &share( {} );
# spent 335µs making 20 calls to Test::Builder::__ANON__[Test/Builder.pm:66], avg 17µs/call
796
797 unless($test) {
798 $out .= "not ";
799 @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
800 }
801 else {
802 @$result{ 'ok', 'actual_ok' } = ( 1, $test );
803 }
804
805 $out .= "ok";
80620262µs $out .= " $self->{Curr_Test}" if $self->use_numbers;
# spent 262µs making 20 calls to Test::Builder::use_numbers, avg 13µs/call
807
808 if( defined $name ) {
80920196µs $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
# spent 196µs making 20 calls to Test::Builder::CORE:subst, avg 10µs/call
810 $out .= " - $name";
811 $result->{name} = $name;
812 }
813 else {
814 $result->{name} = '';
815 }
816
817202.18ms if( $self->in_todo ) {
# spent 2.18ms making 20 calls to Test::Builder::in_todo, avg 109µs/call
818 $out .= " # TODO $todo";
819 $result->{reason} = $todo;
820 $result->{type} = 'todo';
821 }
822 else {
823 $result->{reason} = '';
824 $result->{type} = '';
825 }
826
827 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
828 $out .= "\n";
829
830206.92ms $self->_print($out);
# spent 6.92ms making 20 calls to Test::Builder::_print, avg 346µs/call
831
832 unless($test) {
833 my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
834 $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
835
836 my( undef, $file, $line ) = $self->caller;
837 if( defined $name ) {
838 $self->diag(qq[ $msg test '$name'\n]);
839 $self->diag(qq[ at $file line $line.\n]);
840 }
841 else {
842 $self->diag(qq[ $msg test at $file line $line.\n]);
843 }
844 }
845
846 $self->is_passing(0) unless $test || $self->in_todo;
847
848 # Check that we haven't violated the plan
84920784µs $self->_check_is_passing_plan();
# spent 784µs making 20 calls to Test::Builder::_check_is_passing_plan, avg 39µs/call
850
851 return $test ? 1 : 0;
852}
853
854
855# Check that we haven't yet violated the plan and set
856# is_passing() accordingly
857
# spent 784µs (543+241) within Test::Builder::_check_is_passing_plan which was called 20 times, avg 39µs/call: # 20 times (543µs+241µs) by Test::Builder::ok at line 849, avg 39µs/call
sub _check_is_passing_plan {
85860435µs my $self = shift;
859
86020241µs my $plan = $self->has_plan;
# spent 241µs making 20 calls to Test::Builder::has_plan, avg 12µs/call
861 return unless defined $plan; # no plan yet defined
862 return unless $plan !~ /\D/; # no numeric plan
863 $self->is_passing(0) if $plan < $self->{Curr_Test};
864}
865
866
867
# spent 9.80ms (2.69+7.11) within Test::Builder::_unoverload which was called 40 times, avg 245µs/call: # 40 times (2.69ms+7.11ms) by Test::Builder::_unoverload_str at line 893, avg 245µs/call
sub _unoverload {
8682402.76ms my $self = shift;
869 my $type = shift;
870
87140740µs403.71ms
# spent 341µs within Test::Builder::__ANON__[/home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1/Test/Builder.pm:871] which was called 40 times, avg 9µs/call: # 40 times (341µs+0s) by Test::Builder::_try at line 1460, avg 9µs/call
$self->_try(sub { require overload; }, die_on_fail => 1);
# spent 3.71ms making 40 calls to Test::Builder::_try, avg 93µs/call
872
873 foreach my $thing (@_) {
874403.40ms if( $self->_is_object($$thing) ) {
# spent 3.40ms making 40 calls to Test::Builder::_is_object, avg 85µs/call
875 if( my $string_meth = overload::Method( $$thing, $type ) ) {
876 $$thing = $$thing->$string_meth();
877 }
878 }
879 }
880
881 return;
882}
883
884
# spent 3.40ms (1.45+1.95) within Test::Builder::_is_object which was called 40 times, avg 85µs/call: # 40 times (1.45ms+1.95ms) by Test::Builder::_unoverload at line 874, avg 85µs/call
sub _is_object {
885801.26ms my( $self, $thing ) = @_;
886
88740509µs401.95ms
# spent 232µs within Test::Builder::__ANON__[/home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1/Test/Builder.pm:887] which was called 40 times, avg 6µs/call: # 40 times (232µs+0s) by Test::Builder::_try at line 1460, avg 6µs/call
return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
# spent 1.95ms making 40 calls to Test::Builder::_try, avg 49µs/call
888}
889
890
# spent 10.6ms (828µs+9.80) within Test::Builder::_unoverload_str which was called 40 times, avg 266µs/call: # 20 times (563µs+6.46ms) by Test::Builder::ok at line 779, avg 351µs/call # 20 times (266µs+3.34ms) by Test::Builder::ok at line 792, avg 180µs/call
sub _unoverload_str {
89180722µs my $self = shift;
892
893409.80ms return $self->_unoverload( q[""], @_ );
# spent 9.80ms making 40 calls to Test::Builder::_unoverload, avg 245µs/call
894}
895
896sub _unoverload_num {
897 my $self = shift;
898
899 $self->_unoverload( '0+', @_ );
900
901 for my $val (@_) {
902 next unless $self->_is_dualvar($$val);
903 $$val = $$val + 0;
904 }
905
906 return;
907}
908
909# This is a hack to detect a dualvar such as $!
910sub _is_dualvar {
911 my( $self, $val ) = @_;
912
913 # Objects are not dualvars.
914 return 0 if ref $val;
915
91624.59ms2205µs
# spent 133µs (62+72) within Test::Builder::BEGIN@916 which was called: # once (62µs+72µs) by Test::Builder::Module::BEGIN@5 at line 916
no warnings 'numeric';
# spent 133µs making 1 call to Test::Builder::BEGIN@916 # spent 72µs making 1 call to warnings::unimport
917 my $numval = $val + 0;
918 return $numval != 0 and $numval ne $val ? 1 : 0;
919}
920
921=item B<is_eq>
922
923 $Test->is_eq($got, $expected, $name);
924
925Like Test::More's C<is()>. Checks if C<$got eq $expected>. This is the
926string version.
927
928C<undef> only ever matches another C<undef>.
929
930=item B<is_num>
931
932 $Test->is_num($got, $expected, $name);
933
934Like Test::More's C<is()>. Checks if C<$got == $expected>. This is the
935numeric version.
936
937C<undef> only ever matches another C<undef>.
938
939=cut
940
941sub is_eq {
942 my( $self, $got, $expect, $name ) = @_;
943 local $Level = $Level + 1;
944
945 if( !defined $got || !defined $expect ) {
946 # undef only matches undef and nothing else
947 my $test = !defined $got && !defined $expect;
948
949 $self->ok( $test, $name );
950 $self->_is_diag( $got, 'eq', $expect ) unless $test;
951 return $test;
952 }
953
954 return $self->cmp_ok( $got, 'eq', $expect, $name );
955}
956
957sub is_num {
958 my( $self, $got, $expect, $name ) = @_;
959 local $Level = $Level + 1;
960
961 if( !defined $got || !defined $expect ) {
962 # undef only matches undef and nothing else
963 my $test = !defined $got && !defined $expect;
964
965 $self->ok( $test, $name );
966 $self->_is_diag( $got, '==', $expect ) unless $test;
967 return $test;
968 }
969
970 return $self->cmp_ok( $got, '==', $expect, $name );
971}
972
973sub _diag_fmt {
974 my( $self, $type, $val ) = @_;
975
976 if( defined $$val ) {
977 if( $type eq 'eq' or $type eq 'ne' ) {
978 # quote and force string context
979 $$val = "'$$val'";
980 }
981 else {
982 # force numeric context
983 $self->_unoverload_num($val);
984 }
985 }
986 else {
987 $$val = 'undef';
988 }
989
990 return;
991}
992
993sub _is_diag {
994 my( $self, $got, $type, $expect ) = @_;
995
996 $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
997
998 local $Level = $Level + 1;
999 return $self->diag(<<"DIAGNOSTIC");
1000 got: $got
1001 expected: $expect
1002DIAGNOSTIC
1003
1004}
1005
1006sub _isnt_diag {
1007 my( $self, $got, $type ) = @_;
1008
1009 $self->_diag_fmt( $type, \$got );
1010
1011 local $Level = $Level + 1;
1012 return $self->diag(<<"DIAGNOSTIC");
1013 got: $got
1014 expected: anything else
1015DIAGNOSTIC
1016}
1017
1018=item B<isnt_eq>
1019
1020 $Test->isnt_eq($got, $dont_expect, $name);
1021
1022Like Test::More's C<isnt()>. Checks if C<$got ne $dont_expect>. This is
1023the string version.
1024
1025=item B<isnt_num>
1026
1027 $Test->isnt_num($got, $dont_expect, $name);
1028
1029Like Test::More's C<isnt()>. Checks if C<$got ne $dont_expect>. This is
1030the numeric version.
1031
1032=cut
1033
1034
# spent 4.55ms (133µs+4.42) within Test::Builder::isnt_eq which was called 2 times, avg 2.27ms/call: # 2 times (133µs+4.42ms) by Test::More::isnt at line 383 of Test/More.pm, avg 2.27ms/call
sub isnt_eq {
10358136µs my( $self, $got, $dont_expect, $name ) = @_;
1036 local $Level = $Level + 1;
1037
1038 if( !defined $got || !defined $dont_expect ) {
1039 # undef only matches undef and nothing else
1040 my $test = defined $got || defined $dont_expect;
1041
1042 $self->ok( $test, $name );
1043 $self->_isnt_diag( $got, 'ne' ) unless $test;
1044 return $test;
1045 }
1046
104724.42ms return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
# spent 4.42ms making 2 calls to Test::Builder::cmp_ok, avg 2.21ms/call
1048}
1049
1050sub isnt_num {
1051 my( $self, $got, $dont_expect, $name ) = @_;
1052 local $Level = $Level + 1;
1053
1054 if( !defined $got || !defined $dont_expect ) {
1055 # undef only matches undef and nothing else
1056 my $test = defined $got || defined $dont_expect;
1057
1058 $self->ok( $test, $name );
1059 $self->_isnt_diag( $got, '!=' ) unless $test;
1060 return $test;
1061 }
1062
1063 return $self->cmp_ok( $got, '!=', $dont_expect, $name );
1064}
1065
1066=item B<like>
1067
1068 $Test->like($this, qr/$regex/, $name);
1069 $Test->like($this, '/$regex/', $name);
1070
1071Like Test::More's C<like()>. Checks if $this matches the given C<$regex>.
1072
1073=item B<unlike>
1074
1075 $Test->unlike($this, qr/$regex/, $name);
1076 $Test->unlike($this, '/$regex/', $name);
1077
1078Like Test::More's C<unlike()>. Checks if $this B<does not match> the
1079given C<$regex>.
1080
1081=cut
1082
1083sub like {
1084 my( $self, $this, $regex, $name ) = @_;
1085
1086 local $Level = $Level + 1;
1087 return $self->_regex_ok( $this, $regex, '=~', $name );
1088}
1089
1090sub unlike {
1091 my( $self, $this, $regex, $name ) = @_;
1092
1093 local $Level = $Level + 1;
1094 return $self->_regex_ok( $this, $regex, '!~', $name );
1095}
1096
1097=item B<cmp_ok>
1098
1099 $Test->cmp_ok($this, $type, $that, $name);
1100
1101Works just like Test::More's C<cmp_ok()>.
1102
1103 $Test->cmp_ok($big_num, '!=', $other_big_num);
1104
1105=cut
1106
1107126µsmy %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
1108
1109
# spent 4.42ms (859µs+3.56) within Test::Builder::cmp_ok which was called 2 times, avg 2.21ms/call: # 2 times (859µs+3.56ms) by Test::Builder::isnt_eq at line 1047, avg 2.21ms/call
sub cmp_ok {
111028843µs my( $self, $got, $type, $expect, $name ) = @_;
1111
1112 my $test;
1113 my $error;
1114 {
1115 ## no critic (BuiltinFunctions::ProhibitStringyEval)
1116
1117 local( $@, $!, $SIG{__DIE__} ); # isolate eval
1118
11192297µs my($pack, $file, $line) = $self->caller();
# spent 297µs making 2 calls to Test::Builder::caller, avg 148µs/call
1120
1121 # This is so that warnings come out at the caller's level
1122 $test = eval qq[
1123#line $line "(eval in cmp_ok) $file"
1124\$got $type \$expect;
1125];
1126 $error = $@;
1127 }
1128 local $Level = $Level + 1;
112923.26ms my $ok = $self->ok( $test, $name );
# spent 3.26ms making 2 calls to Test::Builder::ok, avg 1.63ms/call
1130
1131 # Treat overloaded objects as numbers if we're asked to do a
1132 # numeric comparison.
1133 my $unoverload
1134 = $numeric_cmps{$type}
1135 ? '_unoverload_num'
1136 : '_unoverload_str';
1137
1138 $self->diag(<<"END") if $error;
1139An error occurred while using $type:
1140------------------------------------
1141$error
1142------------------------------------
1143END
1144
1145 unless($ok) {
1146 $self->$unoverload( \$got, \$expect );
1147
1148 if( $type =~ /^(eq|==)$/ ) {
1149 $self->_is_diag( $got, $type, $expect );
1150 }
1151 elsif( $type =~ /^(ne|!=)$/ ) {
1152 $self->_isnt_diag( $got, $type );
1153 }
1154 else {
1155 $self->_cmp_diag( $got, $type, $expect );
1156 }
1157 }
1158 return $ok;
1159}
1160
1161sub _cmp_diag {
1162 my( $self, $got, $type, $expect ) = @_;
1163
1164 $got = defined $got ? "'$got'" : 'undef';
1165 $expect = defined $expect ? "'$expect'" : 'undef';
1166
1167 local $Level = $Level + 1;
1168 return $self->diag(<<"DIAGNOSTIC");
1169 $got
1170 $type
1171 $expect
1172DIAGNOSTIC
1173}
1174
1175sub _caller_context {
1176 my $self = shift;
1177
1178 my( $pack, $file, $line ) = $self->caller(1);
1179
1180 my $code = '';
1181 $code .= "#line $line $file\n" if defined $file and defined $line;
1182
1183 return $code;
1184}
1185
1186=back
1187
1188
1189=head2 Other Testing Methods
1190
1191These are methods which are used in the course of writing a test but are not themselves tests.
1192
1193=over 4
1194
1195=item B<BAIL_OUT>
1196
1197 $Test->BAIL_OUT($reason);
1198
1199Indicates to the Test::Harness that things are going so badly all
1200testing should terminate. This includes running any additional test
1201scripts.
1202
1203It will exit with 255.
1204
1205=cut
1206
1207sub BAIL_OUT {
1208 my( $self, $reason ) = @_;
1209
1210 $self->{Bailed_Out} = 1;
1211 $self->_print("Bail out! $reason");
1212 exit 255;
1213}
1214
1215=for deprecated
1216BAIL_OUT() used to be BAILOUT()
1217
1218=cut
1219
1220{
122134.24ms2176µs
# spent 115µs (54+61) within Test::Builder::BEGIN@1221 which was called: # once (54µs+61µs) by Test::Builder::Module::BEGIN@5 at line 1221
no warnings 'once';
# spent 115µs making 1 call to Test::Builder::BEGIN@1221 # spent 61µs making 1 call to warnings::unimport
122217µs *BAILOUT = \&BAIL_OUT;
1223}
1224
1225=item B<skip>
1226
1227 $Test->skip;
1228 $Test->skip($why);
1229
1230Skips the current test, reporting C<$why>.
1231
1232=cut
1233
1234sub skip {
1235 my( $self, $why ) = @_;
1236 $why ||= '';
1237 $self->_unoverload_str( \$why );
1238
1239 lock( $self->{Curr_Test} );
1240 $self->{Curr_Test}++;
1241
1242 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
1243 {
1244 'ok' => 1,
1245 actual_ok => 1,
1246 name => '',
1247 type => 'skip',
1248 reason => $why,
1249 }
1250 );
1251
1252 my $out = "ok";
1253 $out .= " $self->{Curr_Test}" if $self->use_numbers;
1254 $out .= " # skip";
1255 $out .= " $why" if length $why;
1256 $out .= "\n";
1257
1258 $self->_print($out);
1259
1260 return 1;
1261}
1262
1263=item B<todo_skip>
1264
1265 $Test->todo_skip;
1266 $Test->todo_skip($why);
1267
1268Like C<skip()>, only it will declare the test as failing and TODO. Similar
1269to
1270
1271 print "not ok $tnum # TODO $why\n";
1272
1273=cut
1274
1275sub todo_skip {
1276 my( $self, $why ) = @_;
1277 $why ||= '';
1278
1279 lock( $self->{Curr_Test} );
1280 $self->{Curr_Test}++;
1281
1282 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
1283 {
1284 'ok' => 1,
1285 actual_ok => 0,
1286 name => '',
1287 type => 'todo_skip',
1288 reason => $why,
1289 }
1290 );
1291
1292 my $out = "not ok";
1293 $out .= " $self->{Curr_Test}" if $self->use_numbers;
1294 $out .= " # TODO & SKIP $why\n";
1295
1296 $self->_print($out);
1297
1298 return 1;
1299}
1300
1301=begin _unimplemented
1302
1303=item B<skip_rest>
1304
1305 $Test->skip_rest;
1306 $Test->skip_rest($reason);
1307
1308Like C<skip()>, only it skips all the rest of the tests you plan to run
1309and terminates the test.
1310
1311If you're running under C<no_plan>, it skips once and terminates the
1312test.
1313
1314=end _unimplemented
1315
1316=back
1317
1318
1319=head2 Test building utility methods
1320
1321These methods are useful when writing your own test methods.
1322
1323=over 4
1324
1325=item B<maybe_regex>
1326
1327 $Test->maybe_regex(qr/$regex/);
1328 $Test->maybe_regex('/$regex/');
1329
1330This method used to be useful back when Test::Builder worked on Perls
1331before 5.6 which didn't have qr//. Now its pretty useless.
1332
1333Convenience method for building testing functions that take regular
1334expressions as arguments.
1335
1336Takes a quoted regular expression produced by C<qr//>, or a string
1337representing a regular expression.
1338
1339Returns a Perl value which may be used instead of the corresponding
1340regular expression, or C<undef> if its argument is not recognised.
1341
1342For example, a version of C<like()>, sans the useful diagnostic messages,
1343could be written as:
1344
1345 sub laconic_like {
1346 my ($self, $this, $regex, $name) = @_;
1347 my $usable_regex = $self->maybe_regex($regex);
1348 die "expecting regex, found '$regex'\n"
1349 unless $usable_regex;
1350 $self->ok($this =~ m/$usable_regex/, $name);
1351 }
1352
1353=cut
1354
1355sub maybe_regex {
1356 my( $self, $regex ) = @_;
1357 my $usable_regex = undef;
1358
1359 return $usable_regex unless defined $regex;
1360
1361 my( $re, $opts );
1362
1363 # Check for qr/foo/
1364 if( _is_qr($regex) ) {
1365 $usable_regex = $regex;
1366 }
1367 # Check for '/foo/' or 'm,foo,'
1368 elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
1369 ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
1370 )
1371 {
1372 $usable_regex = length $opts ? "(?$opts)$re" : $re;
1373 }
1374
1375 return $usable_regex;
1376}
1377
1378sub _is_qr {
1379 my $regex = shift;
1380
1381 # is_regexp() checks for regexes in a robust manner, say if they're
1382 # blessed.
1383 return re::is_regexp($regex) if defined &re::is_regexp;
1384 return ref $regex eq 'Regexp';
1385}
1386
1387sub _regex_ok {
1388 my( $self, $this, $regex, $cmp, $name ) = @_;
1389
1390 my $ok = 0;
1391 my $usable_regex = $self->maybe_regex($regex);
1392 unless( defined $usable_regex ) {
1393 local $Level = $Level + 1;
1394 $ok = $self->ok( 0, $name );
1395 $self->diag(" '$regex' doesn't look much like a regex to me.");
1396 return $ok;
1397 }
1398
1399 {
1400 ## no critic (BuiltinFunctions::ProhibitStringyEval)
1401
1402 my $test;
1403 my $context = $self->_caller_context;
1404
1405 local( $@, $!, $SIG{__DIE__} ); # isolate eval
1406
1407 $test = eval $context . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
1408
1409 $test = !$test if $cmp eq '!~';
1410
1411 local $Level = $Level + 1;
1412 $ok = $self->ok( $test, $name );
1413 }
1414
1415 unless($ok) {
1416 $this = defined $this ? "'$this'" : 'undef';
1417 my $match = $cmp eq '=~' ? "doesn't match" : "matches";
1418
1419 local $Level = $Level + 1;
1420 $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex );
1421 %s
1422 %13s '%s'
1423DIAGNOSTIC
1424
1425 }
1426
1427 return $ok;
1428}
1429
1430# I'm not ready to publish this. It doesn't deal with array return
1431# values from the code or context.
1432
1433=begin private
1434
1435=item B<_try>
1436
1437 my $return_from_code = $Test->try(sub { code });
1438 my($return_from_code, $error) = $Test->try(sub { code });
1439
1440Works like eval BLOCK except it ensures it has no effect on the rest
1441of the test (ie. C<$@> is not set) nor is effected by outside
1442interference (ie. C<$SIG{__DIE__}>) and works around some quirks in older
1443Perls.
1444
1445C<$error> is what would normally be in C<$@>.
1446
1447It is suggested you use this in place of eval BLOCK.
1448
1449=cut
1450
1451
# spent 7.09ms (5.26+1.83) within Test::Builder::_try which was called 82 times, avg 86µs/call: # 40 times (3.37ms+341µs) by Test::Builder::_unoverload at line 871, avg 93µs/call # 40 times (1.72ms+232µs) by Test::Builder::_is_object at line 887, avg 49µs/call # 2 times (171µs+1.26ms) by Test::Builder::_copy_io_layers at line 1907, avg 714µs/call
sub _try {
14529844.70ms my( $self, $code, %opts ) = @_;
1453
1454 my $error;
1455 my $return;
1456 {
1457 local $!; # eval can mess up $!
1458 local $@; # don't set $@ in the test
1459 local $SIG{__DIE__}; # don't trip an outside DIE handler.
1460821.83ms $return = eval { $code->() };
# spent 1.26ms making 2 calls to Test::Builder::__ANON__[Test/Builder.pm:1906], avg 628µs/call # spent 341µs making 40 calls to Test::Builder::__ANON__[Test/Builder.pm:871], avg 9µs/call # spent 232µs making 40 calls to Test::Builder::__ANON__[Test/Builder.pm:887], avg 6µs/call
1461 $error = $@;
1462 }
1463
1464 die $error if $error and $opts{die_on_fail};
1465
1466 return wantarray ? ( $return, $error ) : $return;
1467}
1468
1469=end private
1470
1471
1472=item B<is_fh>
1473
1474 my $is_fh = $Test->is_fh($thing);
1475
1476Determines if the given C<$thing> can be used as a filehandle.
1477
1478=cut
1479
1480
# spent 27µs within Test::Builder::is_fh which was called 3 times, avg 9µs/call: # 3 times (27µs+0s) by Test::Builder::_new_fh at line 1827, avg 9µs/call
sub is_fh {
14811243µs my $self = shift;
1482 my $maybe_fh = shift;
1483 return 0 unless defined $maybe_fh;
1484
1485 return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
1486 return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
1487
1488 return eval { $maybe_fh->isa("IO::Handle") } ||
1489 eval { tied($maybe_fh)->can('TIEHANDLE') };
1490}
1491
1492=back
1493
1494
1495=head2 Test style
1496
1497
1498=over 4
1499
1500=item B<level>
1501
1502 $Test->level($how_high);
1503
1504How far up the call stack should C<$Test> look when reporting where the
1505test failed.
1506
1507Defaults to 1.
1508
1509Setting L<$Test::Builder::Level> overrides. This is typically useful
1510localized:
1511
1512 sub my_ok {
1513 my $test = shift;
1514
1515 local $Test::Builder::Level = $Test::Builder::Level + 1;
1516 $TB->ok($test);
1517 }
1518
1519To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant.
1520
1521=cut
1522
1523
# spent 728µs within Test::Builder::level which was called 63 times, avg 12µs/call: # 63 times (728µs+0s) by Test::Builder::caller at line 2304, avg 12µs/call
sub level {
1524189946µs my( $self, $level ) = @_;
1525
1526 if( defined $level ) {
1527 $Level = $level;
1528 }
1529 return $Level;
1530}
1531
1532=item B<use_numbers>
1533
1534 $Test->use_numbers($on_or_off);
1535
1536Whether or not the test should output numbers. That is, this if true:
1537
1538 ok 1
1539 ok 2
1540 ok 3
1541
1542or this if false
1543
1544 ok
1545 ok
1546 ok
1547
1548Most useful when you can't depend on the test output order, such as
1549when threads or forking is involved.
1550
1551Defaults to on.
1552
1553=cut
1554
1555
# spent 262µs within Test::Builder::use_numbers which was called 20 times, avg 13µs/call: # 20 times (262µs+0s) by Test::Builder::ok at line 806, avg 13µs/call
sub use_numbers {
155660334µs my( $self, $use_nums ) = @_;
1557
1558 if( defined $use_nums ) {
1559 $self->{Use_Nums} = $use_nums;
1560 }
1561 return $self->{Use_Nums};
1562}
1563
1564=item B<no_diag>
1565
1566 $Test->no_diag($no_diag);
1567
1568If set true no diagnostics will be printed. This includes calls to
1569C<diag()>.
1570
1571=item B<no_ending>
1572
1573 $Test->no_ending($no_ending);
1574
1575Normally, Test::Builder does some extra diagnostics when the test
1576ends. It also changes the exit code as described below.
1577
1578If this is true, none of that will be done.
1579
1580=item B<no_header>
1581
1582 $Test->no_header($no_header);
1583
1584If set to true, no "1..N" header will be printed.
1585
1586=cut
1587
158816µsforeach my $attribute (qw(No_Header No_Ending No_Diag)) {
158937µs my $method = lc $attribute;
1590
1591
# spent 44µs within Test::Builder::__ANON__[/home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1/Test/Builder.pm:1598] which was called 2 times, avg 22µs/call: # once (24µs+0s) by Test::Builder::_print_comment at line 1672 # once (21µs+0s) by Test::Builder::_ending at line 2390
my $code = sub {
1592671µs my( $self, $no ) = @_;
1593
1594 if( defined $no ) {
1595 $self->{$attribute} = $no;
1596 }
1597 return $self->{$attribute};
1598326µs };
1599
160027.17ms2184µs
# spent 113µs (42+71) within Test::Builder::BEGIN@1600 which was called: # once (42µs+71µs) by Test::Builder::Module::BEGIN@5 at line 1600
no strict 'refs'; ## no critic
# spent 113µs making 1 call to Test::Builder::BEGIN@1600 # spent 71µs making 1 call to strict::unimport
1601338µs *{ __PACKAGE__ . '::' . $method } = $code;
1602}
1603
1604=back
1605
1606=head2 Output
1607
1608Controlling where the test output goes.
1609
1610It's ok for your test to change where STDOUT and STDERR point to,
1611Test::Builder's default output settings will not be affected.
1612
1613=over 4
1614
1615=item B<diag>
1616
1617 $Test->diag(@msgs);
1618
1619Prints out the given C<@msgs>. Like C<print>, arguments are simply
1620appended together.
1621
1622Normally, it uses the C<failure_output()> handle, but if this is for a
1623TODO test, the C<todo_output()> handle is used.
1624
1625Output will be indented and marked with a # so as not to interfere
1626with test output. A newline will be put on the end if there isn't one
1627already.
1628
1629We encourage using this rather than calling print directly.
1630
1631Returns false. Why? Because C<diag()> is often used in conjunction with
1632a failing test (C<ok() || diag()>) it "passes through" the failure.
1633
1634 return ok(...) || diag(...);
1635
1636=for blame transfer
1637Mark Fowler <mark@twoshortplanks.com>
1638
1639=cut
1640
1641
# spent 637µs (72+566) within Test::Builder::diag which was called: # once (72µs+566µs) by Test::More::diag at line 1142 of Test/More.pm
sub diag {
1642245µs my $self = shift;
1643
16442566µs $self->_print_comment( $self->_diag_fh, @_ );
# spent 361µs making 1 call to Test::Builder::_print_comment # spent 205µs making 1 call to Test::Builder::_diag_fh
1645}
1646
1647=item B<note>
1648
1649 $Test->note(@msgs);
1650
1651Like C<diag()>, but it prints to the C<output()> handle so it will not
1652normally be seen by the user except in verbose mode.
1653
1654=cut
1655
1656sub note {
1657 my $self = shift;
1658
1659 $self->_print_comment( $self->output, @_ );
1660}
1661
1662
# spent 205µs (64+141) within Test::Builder::_diag_fh which was called: # once (64µs+141µs) by Test::Builder::diag at line 1644
sub _diag_fh {
1663362µs my $self = shift;
1664
1665 local $Level = $Level + 1;
16662141µs return $self->in_todo ? $self->todo_output : $self->failure_output;
# spent 111µs making 1 call to Test::Builder::in_todo # spent 30µs making 1 call to Test::Builder::failure_output
1667}
1668
1669
# spent 361µs (114+246) within Test::Builder::_print_comment which was called: # once (114µs+246µs) by Test::Builder::diag at line 1644
sub _print_comment {
16709125µs my( $self, $fh, @msgs ) = @_;
1671
1672124µs return if $self->no_diag;
# spent 24µs making 1 call to Test::Builder::__ANON__[Test/Builder.pm:1598]
1673 return unless @msgs;
1674
1675 # Prevent printing headers when compiling (i.e. -c)
1676 return if $^C;
1677
1678 # Smash args together like print does.
1679 # Convert undef to 'undef' so its readable.
1680 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1681
1682 # Escape the beginning, _print will take care of the rest.
1683123µs $msg =~ s/^/# /;
# spent 23µs making 1 call to Test::Builder::CORE:subst
1684
1685 local $Level = $Level + 1;
16861200µs $self->_print_to_fh( $fh, $msg );
# spent 200µs making 1 call to Test::Builder::_print_to_fh
1687
1688 return 0;
1689}
1690
1691=item B<explain>
1692
1693 my @dump = $Test->explain(@msgs);
1694
1695Will dump the contents of any references in a human readable format.
1696Handy for things like...
1697
1698 is_deeply($have, $want) || diag explain $have;
1699
1700or
1701
1702 is_deeply($have, $want) || note explain $have;
1703
1704=cut
1705
1706sub explain {
1707 my $self = shift;
1708
1709 return map {
1710 ref $_
1711 ? do {
1712 $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
1713
1714 my $dumper = Data::Dumper->new( [$_] );
1715 $dumper->Indent(1)->Terse(1);
1716 $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
1717 $dumper->Dump;
1718 }
1719 : $_
1720 } @_;
1721}
1722
1723=begin _private
1724
1725=item B<_print>
1726
1727 $Test->_print(@msgs);
1728
1729Prints to the C<output()> filehandle.
1730
1731=end _private
1732
1733=cut
1734
1735
# spent 7.09ms (815µs+6.27) within Test::Builder::_print which was called 21 times, avg 338µs/call: # 20 times (793µs+6.12ms) by Test::Builder::ok at line 830, avg 346µs/call # once (23µs+150µs) by Test::Builder::_output_plan at line 597
sub _print {
1736421.06ms my $self = shift;
1737426.27ms return $self->_print_to_fh( $self->output, @_ );
# spent 5.64ms making 21 calls to Test::Builder::_print_to_fh, avg 268µs/call # spent 636µs making 21 calls to Test::Builder::output, avg 30µs/call
1738}
1739
1740
# spent 5.84ms (2.47+3.36) within Test::Builder::_print_to_fh which was called 22 times, avg 265µs/call: # 21 times (2.40ms+3.24ms) by Test::Builder::_print at line 1737, avg 268µs/call # once (73µs+126µs) by Test::Builder::_print_comment at line 1686
sub _print_to_fh {
17411765.16ms my( $self, $fh, @msgs ) = @_;
1742
1743 # Prevent printing headers when only compiling. Mostly for when
1744 # tests are deparsed with B::Deparse
1745 return if $^C;
1746
1747 my $msg = join '', @msgs;
174822623µs my $indent = $self->_indent;
# spent 623µs making 22 calls to Test::Builder::_indent, avg 28µs/call
1749
1750 local( $\, $", $, ) = ( undef, ' ', '' );
1751
1752 # Escape each line after the first with a # so we don't
1753 # confuse Test::Harness.
175422440µs $msg =~ s{\n(?!\z)}{\n$indent# }sg;
# spent 440µs making 22 calls to Test::Builder::CORE:subst, avg 20µs/call
1755
1756 # Stick a newline on the end if it needs it.
175722256µs $msg .= "\n" unless $msg =~ /\n\z/;
# spent 256µs making 22 calls to Test::Builder::CORE:match, avg 12µs/call
1758
1759222.04ms return print $fh $indent, $msg;
# spent 2.04ms making 22 calls to Test::Builder::CORE:print, avg 93µs/call
1760}
1761
1762=item B<output>
1763
1764=item B<failure_output>
1765
1766=item B<todo_output>
1767
1768 my $filehandle = $Test->output;
1769 $Test->output($filehandle);
1770 $Test->output($filename);
1771 $Test->output(\$scalar);
1772
1773These methods control where Test::Builder will print its output.
1774They take either an open C<$filehandle>, a C<$filename> to open and write to
1775or a C<$scalar> reference to append to. It will always return a C<$filehandle>.
1776
1777B<output> is where normal "ok/not ok" test output goes.
1778
1779Defaults to STDOUT.
1780
1781B<failure_output> is where diagnostic output on test failures and
1782C<diag()> goes. It is normally not read by Test::Harness and instead is
1783displayed to the user.
1784
1785Defaults to STDERR.
1786
1787C<todo_output> is used instead of C<failure_output()> for the
1788diagnostics of a failing TODO test. These will not be seen by the
1789user.
1790
1791Defaults to STDOUT.
1792
1793=cut
1794
1795
# spent 699µs (661+38) within Test::Builder::output which was called 22 times, avg 32µs/call: # 21 times (636µs+0s) by Test::Builder::_print at line 1737, avg 30µs/call # once (25µs+38µs) by Test::Builder::reset_outputs at line 1931
sub output {
179666415µs my( $self, $fh ) = @_;
1797
1798138µs if( defined $fh ) {
# spent 38µs making 1 call to Test::Builder::_new_fh
1799 $self->{Out_FH} = $self->_new_fh($fh);
1800 }
1801 return $self->{Out_FH};
1802}
1803
1804
# spent 77µs (54+23) within Test::Builder::failure_output which was called 2 times, avg 39µs/call: # once (24µs+23µs) by Test::Builder::reset_outputs at line 1932 # once (30µs+0s) by Test::Builder::_diag_fh at line 1666
sub failure_output {
1805664µs my( $self, $fh ) = @_;
1806
1807123µs if( defined $fh ) {
# spent 23µs making 1 call to Test::Builder::_new_fh
1808 $self->{Fail_FH} = $self->_new_fh($fh);
1809 }
1810 return $self->{Fail_FH};
1811}
1812
1813
# spent 44µs (22+23) within Test::Builder::todo_output which was called: # once (22µs+23µs) by Test::Builder::reset_outputs at line 1933
sub todo_output {
1814330µs my( $self, $fh ) = @_;
1815
1816123µs if( defined $fh ) {
# spent 23µs making 1 call to Test::Builder::_new_fh
1817 $self->{Todo_FH} = $self->_new_fh($fh);
1818 }
1819 return $self->{Todo_FH};
1820}
1821
1822
# spent 84µs (57+27) within Test::Builder::_new_fh which was called 3 times, avg 28µs/call: # once (25µs+13µs) by Test::Builder::output at line 1798 # once (16µs+7µs) by Test::Builder::failure_output at line 1807 # once (15µs+7µs) by Test::Builder::todo_output at line 1816
sub _new_fh {
18231560µs my $self = shift;
1824 my($file_or_fh) = shift;
1825
1826 my $fh;
1827327µs if( $self->is_fh($file_or_fh) ) {
# spent 27µs making 3 calls to Test::Builder::is_fh, avg 9µs/call
1828 $fh = $file_or_fh;
1829 }
1830 elsif( ref $file_or_fh eq 'SCALAR' ) {
1831 # Scalar refs as filehandles was added in 5.8.
1832 if( $] >= 5.008 ) {
1833 open $fh, ">>", $file_or_fh
1834 or $self->croak("Can't open scalar ref $file_or_fh: $!");
1835 }
1836 # Emulate scalar ref filehandles with a tie.
1837 else {
1838 $fh = Test::Builder::IO::Scalar->new($file_or_fh)
1839 or $self->croak("Can't tie scalar ref $file_or_fh");
1840 }
1841 }
1842 else {
1843 open $fh, ">", $file_or_fh
1844 or $self->croak("Can't open test output log $file_or_fh: $!");
1845 _autoflush($fh);
1846 }
1847
1848 return $fh;
1849}
1850
1851
# spent 134µs (104+30) within Test::Builder::_autoflush which was called 4 times, avg 34µs/call: # once (43µs+16µs) by Test::Builder::_dup_stdhandles at line 1869 # once (21µs+5µs) by Test::Builder::_dup_stdhandles at line 1870 # once (20µs+4µs) by Test::Builder::_dup_stdhandles at line 1871 # once (20µs+5µs) by Test::Builder::_dup_stdhandles at line 1872
sub _autoflush {
185220157µs my($fh) = shift;
1853420µs my $old_fh = select $fh;
# spent 20µs making 4 calls to Test::Builder::CORE:select, avg 5µs/call
1854 $| = 1;
1855410µs select $old_fh;
# spent 10µs making 4 calls to Test::Builder::CORE:select, avg 3µs/call
1856
1857 return;
1858}
1859
186011µsmy( $Testout, $Testerr );
1861
1862
# spent 2.17ms (81µs+2.09) within Test::Builder::_dup_stdhandles which was called: # once (81µs+2.09ms) by Test::Builder::reset at line 437
sub _dup_stdhandles {
1863851µs my $self = shift;
1864
186511.74ms $self->_open_testhandles;
# spent 1.74ms making 1 call to Test::Builder::_open_testhandles
1866
1867 # Set everything to unbuffered else plain prints to STDOUT will
1868 # come out in the wrong order from our own prints.
1869159µs _autoflush($Testout);
# spent 59µs making 1 call to Test::Builder::_autoflush
1870126µs _autoflush( \*STDOUT );
# spent 26µs making 1 call to Test::Builder::_autoflush
1871125µs _autoflush($Testerr);
# spent 25µs making 1 call to Test::Builder::_autoflush
1872124µs _autoflush( \*STDERR );
# spent 24µs making 1 call to Test::Builder::_autoflush
1873
18741209µs $self->reset_outputs;
# spent 209µs making 1 call to Test::Builder::reset_outputs
1875
1876 return;
1877}
1878
1879
# spent 1.74ms (101µs+1.64) within Test::Builder::_open_testhandles which was called: # once (101µs+1.64ms) by Test::Builder::_dup_stdhandles at line 1865
sub _open_testhandles {
18808225µs my $self = shift;
1881
1882 return if $self->{Opened_Testhandles};
1883
1884 # We dup STDOUT and STDERR so people can change them in their
1885 # test suites while still getting normal test output.
18861104µs open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
# spent 104µs making 1 call to Test::Builder::CORE:open
1887126µs open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!";
# spent 26µs making 1 call to Test::Builder::CORE:open
1888
188911.34ms $self->_copy_io_layers( \*STDOUT, $Testout );
# spent 1.34ms making 1 call to Test::Builder::_copy_io_layers
18901177µs $self->_copy_io_layers( \*STDERR, $Testerr );
# spent 177µs making 1 call to Test::Builder::_copy_io_layers
1891
1892 $self->{Opened_Testhandles} = 1;
1893
1894 return;
1895}
1896
1897
# spent 1.51ms (87µs+1.43) within Test::Builder::_copy_io_layers which was called 2 times, avg 757µs/call: # once (52µs+1.29ms) by Test::Builder::_open_testhandles at line 1889 # once (35µs+142µs) by Test::Builder::_open_testhandles at line 1890
sub _copy_io_layers {
1898688µs my( $self, $src, $dst ) = @_;
1899
1900 $self->_try(
1901
# spent 1.26ms (1.08+179µs) within Test::Builder::__ANON__[/home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1/Test/Builder.pm:1906] which was called 2 times, avg 628µs/call: # 2 times (1.08ms+179µs) by Test::Builder::_try at line 1460, avg 628µs/call
sub {
190261.09ms require PerlIO;
1903234µs my @src_layers = PerlIO::get_layers($src);
# spent 34µs making 2 calls to PerlIO::get_layers, avg 17µs/call
1904
19052145µs _apply_layers($dst, @src_layers) if @src_layers;
# spent 145µs making 2 calls to Test::Builder::_apply_layers, avg 73µs/call
1906 }
190721.43ms );
# spent 1.43ms making 2 calls to Test::Builder::_try, avg 714µs/call
1908
1909 return;
1910}
1911
1912
# spent 145µs (96+49) within Test::Builder::_apply_layers which was called 2 times, avg 73µs/call: # 2 times (96µs+49µs) by Test::Builder::__ANON__[/home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1/Test/Builder.pm:1906] at line 1905, avg 73µs/call
sub _apply_layers {
19138155µs my ($fh, @layers) = @_;
1914 my %seen;
1915 my @unique = grep { $_ ne 'unix' and !$seen{$_}++ } @layers;
1916249µs binmode($fh, join(":", "", "raw", @unique));
# spent 49µs making 2 calls to Test::Builder::CORE:binmode, avg 25µs/call
1917}
1918
1919
1920=item reset_outputs
1921
1922 $tb->reset_outputs;
1923
1924Resets all the output filehandles back to their defaults.
1925
1926=cut
1927
1928
# spent 209µs (54+155) within Test::Builder::reset_outputs which was called: # once (54µs+155µs) by Test::Builder::_dup_stdhandles at line 1874
sub reset_outputs {
1929534µs my $self = shift;
1930
1931163µs $self->output ($Testout);
# spent 63µs making 1 call to Test::Builder::output
1932147µs $self->failure_output($Testerr);
# spent 47µs making 1 call to Test::Builder::failure_output
1933144µs $self->todo_output ($Testout);
# spent 44µs making 1 call to Test::Builder::todo_output
1934
1935 return;
1936}
1937
1938=item carp
1939
1940 $tb->carp(@message);
1941
1942Warns with C<@message> but the message will appear to come from the
1943point where the original test function was called (C<< $tb->caller >>).
1944
1945=item croak
1946
1947 $tb->croak(@message);
1948
1949Dies with C<@message> but the message will appear to come from the
1950point where the original test function was called (C<< $tb->caller >>).
1951
1952=cut
1953
1954sub _message_at_caller {
1955 my $self = shift;
1956
1957 local $Level = $Level + 1;
1958 my( $pack, $file, $line ) = $self->caller;
1959 return join( "", @_ ) . " at $file line $line.\n";
1960}
1961
1962sub carp {
1963 my $self = shift;
1964 return warn $self->_message_at_caller(@_);
1965}
1966
1967sub croak {
1968 my $self = shift;
1969 return die $self->_message_at_caller(@_);
1970}
1971
1972
1973=back
1974
1975
1976=head2 Test Status and Info
1977
1978=over 4
1979
1980=item B<current_test>
1981
1982 my $curr_test = $Test->current_test;
1983 $Test->current_test($num);
1984
1985Gets/sets the current test number we're on. You usually shouldn't
1986have to set this.
1987
1988If set forward, the details of the missing tests are filled in as 'unknown'.
1989if set backward, the details of the intervening tests are deleted. You
1990can erase history if you really want to.
1991
1992=cut
1993
1994
# spent 61µs (54+7) within Test::Builder::current_test which was called: # once (54µs+7µs) by Test::Builder::done_testing at line 648
sub current_test {
1995447µs my( $self, $num ) = @_;
1996
199717µs lock( $self->{Curr_Test} );
# spent 7µs making 1 call to Test::Builder::__ANON__[Test/Builder.pm:67]
1998 if( defined $num ) {
1999 $self->{Curr_Test} = $num;
2000
2001 # If the test counter is being pushed forward fill in the details.
2002 my $test_results = $self->{Test_Results};
2003 if( $num > @$test_results ) {
2004 my $start = @$test_results ? @$test_results : 0;
2005 for( $start .. $num - 1 ) {
2006 $test_results->[$_] = &share(
2007 {
2008 'ok' => 1,
2009 actual_ok => undef,
2010 reason => 'incrementing test number',
2011 type => 'unknown',
2012 name => undef
2013 }
2014 );
2015 }
2016 }
2017 # If backward, wipe history. Its their funeral.
2018 elsif( $num < @$test_results ) {
2019 $#{$test_results} = $num - 1;
2020 }
2021 }
2022 return $self->{Curr_Test};
2023}
2024
2025=item B<is_passing>
2026
2027 my $ok = $builder->is_passing;
2028
2029Indicates if the test suite is currently passing.
2030
2031More formally, it will be false if anything has happened which makes
2032it impossible for the test suite to pass. True otherwise.
2033
2034For example, if no tests have run C<is_passing()> will be true because
2035even though a suite with no tests is a failure you can add a passing
2036test to it and start passing.
2037
2038Don't think about it too much.
2039
2040=cut
2041
2042
# spent 15µs within Test::Builder::is_passing which was called: # once (15µs+0s) by Test::Builder::reset at line 407
sub is_passing {
2043335µs my $self = shift;
2044
2045 if( @_ ) {
2046 $self->{Is_Passing} = shift;
2047 }
2048
2049 return $self->{Is_Passing};
2050}
2051
2052
2053=item B<summary>
2054
2055 my @tests = $Test->summary;
2056
2057A simple summary of the tests so far. True for pass, false for fail.
2058This is a logical pass/fail, so todos are passes.
2059
2060Of course, test #1 is $tests[0], etc...
2061
2062=cut
2063
2064sub summary {
2065 my($self) = shift;
2066
2067 return map { $_->{'ok'} } @{ $self->{Test_Results} };
2068}
2069
2070=item B<details>
2071
2072 my @tests = $Test->details;
2073
2074Like C<summary()>, but with a lot more detail.
2075
2076 $tests[$test_num - 1] =
2077 { 'ok' => is the test considered a pass?
2078 actual_ok => did it literally say 'ok'?
2079 name => name of the test (if any)
2080 type => type of test (if any, see below).
2081 reason => reason for the above (if any)
2082 };
2083
2084'ok' is true if Test::Harness will consider the test to be a pass.
2085
2086'actual_ok' is a reflection of whether or not the test literally
2087printed 'ok' or 'not ok'. This is for examining the result of 'todo'
2088tests.
2089
2090'name' is the name of the test.
2091
2092'type' indicates if it was a special test. Normal tests have a type
2093of ''. Type can be one of the following:
2094
2095 skip see skip()
2096 todo see todo()
2097 todo_skip see todo_skip()
2098 unknown see below
2099
2100Sometimes the Test::Builder test counter is incremented without it
2101printing any test output, for example, when C<current_test()> is changed.
2102In these cases, Test::Builder doesn't know the result of the test, so
2103its type is 'unknown'. These details for these tests are filled in.
2104They are considered ok, but the name and actual_ok is left C<undef>.
2105
2106For example "not ok 23 - hole count # TODO insufficient donuts" would
2107result in this structure:
2108
2109 $tests[22] = # 23 - 1, since arrays start from 0.
2110 { ok => 1, # logically, the test passed since its todo
2111 actual_ok => 0, # in absolute terms, it failed
2112 name => 'hole count',
2113 type => 'todo',
2114 reason => 'insufficient donuts'
2115 };
2116
2117=cut
2118
2119sub details {
2120 my $self = shift;
2121 return @{ $self->{Test_Results} };
2122}
2123
2124=item B<todo>
2125
2126 my $todo_reason = $Test->todo;
2127 my $todo_reason = $Test->todo($pack);
2128
2129If the current tests are considered "TODO" it will return the reason,
2130if any. This reason can come from a C<$TODO> variable or the last call
2131to C<todo_start()>.
2132
2133Since a TODO test does not need a reason, this function can return an
2134empty string even when inside a TODO block. Use C<< $Test->in_todo >>
2135to determine if you are currently inside a TODO block.
2136
2137C<todo()> is about finding the right package to look for C<$TODO> in. It's
2138pretty good at guessing the right package to look at. It first looks for
2139the caller based on C<$Level + 1>, since C<todo()> is usually called inside
2140a test function. As a last resort it will use C<exported_to()>.
2141
2142Sometimes there is some confusion about where todo() should be looking
2143for the C<$TODO> variable. If you want to be sure, tell it explicitly
2144what $pack to use.
2145
2146=cut
2147
2148
# spent 4.07ms (1.08+2.99) within Test::Builder::todo which was called 20 times, avg 203µs/call: # 20 times (1.08ms+2.99ms) by Test::Builder::ok at line 788, avg 203µs/call
sub todo {
2149120855µs my( $self, $pack ) = @_;
2150
2151 return $self->{Todo} if defined $self->{Todo};
2152
2153 local $Level = $Level + 1;
2154202.99ms my $todo = $self->find_TODO($pack);
# spent 2.99ms making 20 calls to Test::Builder::find_TODO, avg 149µs/call
2155 return $todo if defined $todo;
2156
2157 return '';
2158}
2159
2160=item B<find_TODO>
2161
2162 my $todo_reason = $Test->find_TODO();
2163 my $todo_reason = $Test->find_TODO($pack);
2164
2165Like C<todo()> but only returns the value of C<$TODO> ignoring
2166C<todo_start()>.
2167
2168Can also be used to set C<$TODO> to a new value while returning the
2169old value:
2170
2171 my $old_reason = $Test->find_TODO($pack, 1, $new_reason);
2172
2173=cut
2174
2175
# spent 6.31ms (1.88+4.43) within Test::Builder::find_TODO which was called 61 times, avg 104µs/call: # 41 times (891µs+2.44ms) by Test::Builder::in_todo at line 2199, avg 81µs/call # 20 times (989µs+2.00ms) by Test::Builder::todo at line 2154, avg 149µs/call
sub find_TODO {
21763661.97ms my( $self, $pack, $set, $new_value ) = @_;
2177
2178614.43ms $pack = $pack || $self->caller(1) || $self->exported_to;
# spent 4.43ms making 61 calls to Test::Builder::caller, avg 73µs/call
2179 return unless $pack;
2180
218124.44ms2192µs
# spent 120µs (47+72) within Test::Builder::BEGIN@2181 which was called: # once (47µs+72µs) by Test::Builder::Module::BEGIN@5 at line 2181
no strict 'refs'; ## no critic
# spent 120µs making 1 call to Test::Builder::BEGIN@2181 # spent 72µs making 1 call to strict::unimport
2182 my $old_value = ${ $pack . '::TODO' };
2183 $set and ${ $pack . '::TODO' } = $new_value;
2184 return $old_value;
2185}
2186
2187=item B<in_todo>
2188
2189 my $in_todo = $Test->in_todo;
2190
2191Returns true if the test is currently inside a TODO block.
2192
2193=cut
2194
2195
# spent 4.16ms (833µs+3.33) within Test::Builder::in_todo which was called 41 times, avg 101µs/call: # 20 times (394µs+1.79ms) by Test::Builder::ok at line 817, avg 109µs/call # 20 times (418µs+1.45ms) by Test::Builder::ok at line 789, avg 93µs/call # once (20µs+91µs) by Test::Builder::_diag_fh at line 1666
sub in_todo {
2196123792µs my $self = shift;
2197
2198 local $Level = $Level + 1;
2199413.33ms return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
# spent 3.33ms making 41 calls to Test::Builder::find_TODO, avg 81µs/call
2200}
2201
2202=item B<todo_start>
2203
2204 $Test->todo_start();
2205 $Test->todo_start($message);
2206
2207This method allows you declare all subsequent tests as TODO tests, up until
2208the C<todo_end> method has been called.
2209
2210The C<TODO:> and C<$TODO> syntax is generally pretty good about figuring out
2211whether or not we're in a TODO test. However, often we find that this is not
2212possible to determine (such as when we want to use C<$TODO> but
2213the tests are being executed in other packages which can't be inferred
2214beforehand).
2215
2216Note that you can use this to nest "todo" tests
2217
2218 $Test->todo_start('working on this');
2219 # lots of code
2220 $Test->todo_start('working on that');
2221 # more code
2222 $Test->todo_end;
2223 $Test->todo_end;
2224
2225This is generally not recommended, but large testing systems often have weird
2226internal needs.
2227
2228We've tried to make this also work with the TODO: syntax, but it's not
2229guaranteed and its use is also discouraged:
2230
2231 TODO: {
2232 local $TODO = 'We have work to do!';
2233 $Test->todo_start('working on this');
2234 # lots of code
2235 $Test->todo_start('working on that');
2236 # more code
2237 $Test->todo_end;
2238 $Test->todo_end;
2239 }
2240
2241Pick one style or another of "TODO" to be on the safe side.
2242
2243=cut
2244
2245sub todo_start {
2246 my $self = shift;
2247 my $message = @_ ? shift : '';
2248
2249 $self->{Start_Todo}++;
2250 if( $self->in_todo ) {
2251 push @{ $self->{Todo_Stack} } => $self->todo;
2252 }
2253 $self->{Todo} = $message;
2254
2255 return;
2256}
2257
2258=item C<todo_end>
2259
2260 $Test->todo_end;
2261
2262Stops running tests as "TODO" tests. This method is fatal if called without a
2263preceding C<todo_start> method call.
2264
2265=cut
2266
2267sub todo_end {
2268 my $self = shift;
2269
2270 if( !$self->{Start_Todo} ) {
2271 $self->croak('todo_end() called without todo_start()');
2272 }
2273
2274 $self->{Start_Todo}--;
2275
2276 if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
2277 $self->{Todo} = pop @{ $self->{Todo_Stack} };
2278 }
2279 else {
2280 delete $self->{Todo};
2281 }
2282
2283 return;
2284}
2285
2286=item B<caller>
2287
2288 my $package = $Test->caller;
2289 my($pack, $file, $line) = $Test->caller;
2290 my($pack, $file, $line) = $Test->caller($height);
2291
2292Like the normal C<caller()>, except it reports according to your C<level()>.
2293
2294C<$height> will be added to the C<level()>.
2295
2296If C<caller()> winds up off the top of the stack it report the highest context.
2297
2298=cut
2299
2300
# spent 4.73ms (4.00+728µs) within Test::Builder::caller which was called 63 times, avg 75µs/call: # 61 times (3.77ms+669µs) by Test::Builder::find_TODO at line 2178, avg 73µs/call # 2 times (238µs+59µs) by Test::Builder::cmp_ok at line 1119, avg 148µs/call
sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
23015043.78ms my( $self, $height ) = @_;
2302 $height ||= 0;
2303
230463728µs my $level = $self->level + $height + 1;
# spent 728µs making 63 calls to Test::Builder::level, avg 12µs/call
2305 my @caller;
2306 do {
2307 @caller = CORE::caller( $level );
2308 $level--;
2309 } until @caller;
2310 return wantarray ? @caller : $caller[0];
2311}
2312
2313=back
2314
2315=cut
2316
2317=begin _private
2318
2319=over 4
2320
2321=item B<_sanity_check>
2322
2323 $self->_sanity_check();
2324
2325Runs a bunch of end of test sanity checks to make sure reality came
2326through ok. If anything is wrong it will die with a fairly friendly
2327error message.
2328
2329=cut
2330
2331#'#
2332sub _sanity_check {
2333 my $self = shift;
2334
2335 $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
2336 $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
2337 'Somehow you got a different number of results than tests ran!' );
2338
2339 return;
2340}
2341
2342=item B<_whoa>
2343
2344 $self->_whoa($check, $description);
2345
2346A sanity check, similar to C<assert()>. If the C<$check> is true, something
2347has gone horribly wrong. It will die with the given C<$description> and
2348a note to contact the author.
2349
2350=cut
2351
2352sub _whoa {
2353 my( $self, $check, $desc ) = @_;
2354 if($check) {
2355 local $Level = $Level + 1;
2356 $self->croak(<<"WHOA");
2357WHOA! $desc
2358This should never happen! Please contact the author immediately!
2359WHOA
2360 }
2361
2362 return;
2363}
2364
2365=item B<_my_exit>
2366
2367 _my_exit($exit_num);
2368
2369Perl seems to have some trouble with exiting inside an C<END> block.
23705.6.1 does some odd things. Instead, this function edits C<$?>
2371directly. It should B<only> be called from inside an C<END> block.
2372It doesn't actually exit, that's your job.
2373
2374=cut
2375
2376
# spent 11µs within Test::Builder::_my_exit which was called: # once (11µs+0s) by Test::Builder::_ending at line 2479
sub _my_exit {
2377230µs $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
2378
2379 return 1;
2380}
2381
2382=back
2383
2384=end _private
2385
2386=cut
2387
2388
# spent 295µs (254+41) within Test::Builder::_ending which was called: # once (254µs+41µs) by Test::Builder::END at line 2502
sub _ending {
238942220µs my $self = shift;
2390121µs return if $self->no_ending;
# spent 21µs making 1 call to Test::Builder::__ANON__[Test/Builder.pm:1598]
2391 return if $self->{Ending}++;
2392
2393 my $real_exit_code = $?;
2394
2395 # Don't bother with an ending if this is a forked copy. Only the parent
2396 # should do the ending.
2397 if( $self->{Original_Pid} != $$ ) {
2398 return;
2399 }
2400
2401 # Ran tests but never declared a plan or hit done_testing
2402 if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
2403 $self->is_passing(0);
2404 $self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
2405 }
2406
2407 # Exit if plan() was never called. This is so "require Test::Simple"
2408 # doesn't puke.
2409 if( !$self->{Have_Plan} ) {
2410 return;
2411 }
2412
2413 # Don't do an ending if we bailed out.
2414 if( $self->{Bailed_Out} ) {
2415 $self->is_passing(0);
2416 return;
2417 }
2418 # Figure out if we passed or failed and print helpful messages.
2419 my $test_results = $self->{Test_Results};
2420 if(@$test_results) {
2421 # The plan? We have no plan.
2422 if( $self->{No_Plan} ) {
2423 $self->_output_plan($self->{Curr_Test}) unless $self->no_header;
2424 $self->{Expected_Tests} = $self->{Curr_Test};
2425 }
2426
2427 # Auto-extended arrays and elements which aren't explicitly
2428 # filled in with a shared reference will puke under 5.8.0
2429 # ithreads. So we have to fill them in by hand. :(
243019µs my $empty_result = &share( {} );
# spent 9µs making 1 call to Test::Builder::__ANON__[Test/Builder.pm:66]
2431 for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
2432 $test_results->[$idx] = $empty_result
2433 unless defined $test_results->[$idx];
2434 }
2435
2436 my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
2437
2438 my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
2439
2440 if( $num_extra != 0 ) {
2441 my $s = $self->{Expected_Tests} == 1 ? '' : 's';
2442 $self->diag(<<"FAIL");
2443Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}.
2444FAIL
2445 $self->is_passing(0);
2446 }
2447
2448 if($num_failed) {
2449 my $num_tests = $self->{Curr_Test};
2450 my $s = $num_failed == 1 ? '' : 's';
2451
2452 my $qualifier = $num_extra == 0 ? '' : ' run';
2453
2454 $self->diag(<<"FAIL");
2455Looks like you failed $num_failed test$s of $num_tests$qualifier.
2456FAIL
2457 $self->is_passing(0);
2458 }
2459
2460 if($real_exit_code) {
2461 $self->diag(<<"FAIL");
2462Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
2463FAIL
2464 $self->is_passing(0);
2465 _my_exit($real_exit_code) && return;
2466 }
2467
2468 my $exit_code;
2469 if($num_failed) {
2470 $exit_code = $num_failed <= 254 ? $num_failed : 254;
2471 }
2472 elsif( $num_extra != 0 ) {
2473 $exit_code = 255;
2474 }
2475 else {
2476 $exit_code = 0;
2477 }
2478
2479111µs _my_exit($exit_code) && return;
# spent 11µs making 1 call to Test::Builder::_my_exit
2480 }
2481 elsif( $self->{Skip_All} ) {
2482 _my_exit(0) && return;
2483 }
2484 elsif($real_exit_code) {
2485 $self->diag(<<"FAIL");
2486Looks like your test exited with $real_exit_code before it could output anything.
2487FAIL
2488 $self->is_passing(0);
2489 _my_exit($real_exit_code) && return;
2490 }
2491 else {
2492 $self->diag("No tests run!\n");
2493 $self->is_passing(0);
2494 _my_exit(255) && return;
2495 }
2496
2497 $self->is_passing(0);
2498 $self->_whoa( 1, "We fell off the end of _ending()" );
2499}
2500
2501
# spent 339µs (44+295) within Test::Builder::END which was called: # once (44µs+295µs) by main::RUNTIME at line 0 of t/app_dpath.t
END {
250214.14ms1295µs $Test->_ending if defined $Test;
# spent 295µs making 1 call to Test::Builder::_ending
2503}
2504
2505=head1 EXIT CODES
2506
2507If all your tests passed, Test::Builder will exit with zero (which is
2508normal). If anything failed it will exit with how many failed. If
2509you run less (or more) tests than you planned, the missing (or extras)
2510will be considered failures. If no tests were ever run Test::Builder
2511will throw a warning and exit with 255. If the test died, even after
2512having successfully completed all its tests, it will still be
2513considered a failure and will exit with 255.
2514
2515So the exit codes are...
2516
2517 0 all tests successful
2518 255 test died or all passed but wrong # of tests run
2519 any other number how many failed (including missing or extras)
2520
2521If you fail more than 254 tests, it will be reported as 254.
2522
2523=head1 THREADS
2524
2525In perl 5.8.1 and later, Test::Builder is thread-safe. The test
2526number is shared amongst all threads. This means if one thread sets
2527the test number using C<current_test()> they will all be effected.
2528
2529While versions earlier than 5.8.1 had threads they contain too many
2530bugs to support.
2531
2532Test::Builder is only thread-aware if threads.pm is loaded I<before>
2533Test::Builder.
2534
2535=head1 MEMORY
2536
2537An informative hash, accessible via C<<details()>>, is stored for each
2538test you perform. So memory usage will scale linearly with each test
2539run. Although this is not a problem for most test suites, it can
2540become an issue if you do large (hundred thousands to million)
2541combinatorics tests in the same run.
2542
2543In such cases, you are advised to either split the test file into smaller
2544ones, or use a reverse approach, doing "normal" (code) compares and
2545triggering fail() should anything go unexpected.
2546
2547Future versions of Test::Builder will have a way to turn history off.
2548
2549
2550=head1 EXAMPLES
2551
2552CPAN can provide the best examples. Test::Simple, Test::More,
2553Test::Exception and Test::Differences all use Test::Builder.
2554
2555=head1 SEE ALSO
2556
2557Test::Simple, Test::More, Test::Harness
2558
2559=head1 AUTHORS
2560
2561Original code by chromatic, maintained by Michael G Schwern
2562E<lt>schwern@pobox.comE<gt>
2563
2564=head1 COPYRIGHT
2565
2566Copyright 2002-2008 by chromatic E<lt>chromatic@wgz.orgE<gt> and
2567 Michael G Schwern E<lt>schwern@pobox.comE<gt>.
2568
2569This program is free software; you can redistribute it and/or
2570modify it under the same terms as Perl itself.
2571
2572See F<http://www.perl.com/perl/misc/Artistic.html>
2573
2574=cut
2575
2576152µs1;
2577
 
# spent 49µs within Test::Builder::CORE:binmode which was called 2 times, avg 25µs/call: # 2 times (49µs+0s) by Test::Builder::_apply_layers at line 1916, avg 25µs/call
sub Test::Builder::CORE:binmode; # opcode
# spent 1.07ms within Test::Builder::CORE:match which was called 42 times, avg 25µs/call: # 22 times (256µs+0s) by Test::Builder::_print_to_fh at line 1757, avg 12µs/call # 20 times (809µs+0s) by Test::Builder::ok at line 781, avg 40µs/call
sub Test::Builder::CORE:match; # opcode
# spent 129µs within Test::Builder::CORE:open which was called 2 times, avg 65µs/call: # once (104µs+0s) by Test::Builder::_open_testhandles at line 1886 # once (26µs+0s) by Test::Builder::_open_testhandles at line 1887
sub Test::Builder::CORE:open; # opcode
# spent 2.04ms within Test::Builder::CORE:print which was called 22 times, avg 93µs/call: # 22 times (2.04ms+0s) by Test::Builder::_print_to_fh at line 1759, avg 93µs/call
sub Test::Builder::CORE:print; # opcode
# spent 30µs within Test::Builder::CORE:select which was called 8 times, avg 4µs/call: # 4 times (20µs+0s) by Test::Builder::_autoflush at line 1853, avg 5µs/call # 4 times (10µs+0s) by Test::Builder::_autoflush at line 1855, avg 3µs/call
sub Test::Builder::CORE:select; # opcode
# spent 659µs within Test::Builder::CORE:subst which was called 43 times, avg 15µs/call: # 22 times (440µs+0s) by Test::Builder::_print_to_fh at line 1754, avg 20µs/call # 20 times (196µs+0s) by Test::Builder::ok at line 809, avg 10µs/call # once (23µs+0s) by Test::Builder::_print_comment at line 1683
sub Test::Builder::CORE:subst; # opcode