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

Filename/home/ss5/perl5/perlbrew/perls/tapper-perl/lib/5.16.3/Test/Builder.pm
StatementsExecuted 1340 statements in 10.7ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
111643µs1.53msTest::Builder::::BEGIN@19Test::Builder::BEGIN@19
533291µs1.60msTest::Builder::::okTest::Builder::ok
2231288µs571µsTest::Builder::::_tryTest::Builder::_try
211209µs255µsTest::Builder::::__ANON__[:1968]Test::Builder::__ANON__[:1968]
1721200µs228µsTest::Builder::::callerTest::Builder::caller
1011140µs481µsTest::Builder::::_unoverloadTest::Builder::_unoverload
611132µs132µsTest::Builder::::CORE:printTest::Builder::CORE:print (opcode)
611130µs303µsTest::Builder::::_print_to_fhTest::Builder::_print_to_fh
211122µs659µsTest::Builder::::cmp_okTest::Builder::cmp_ok
152197µs294µsTest::Builder::::find_TODOTest::Builder::find_TODO
101165µs182µsTest::Builder::::_is_objectTest::Builder::_is_object
102149µs218µsTest::Builder::::in_todoTest::Builder::in_todo
51145µs63µsTest::Builder::::_check_is_passing_planTest::Builder::_check_is_passing_plan
62145µs362µsTest::Builder::::_printTest::Builder::_print
102143µs524µsTest::Builder::::_unoverload_strTest::Builder::_unoverload_str
11142µs50µsTest::Builder::::_endingTest::Builder::_ending
174141µs41µsTest::Builder::::CORE:matchTest::Builder::CORE:match (opcode)
51139µs164µsTest::Builder::::todoTest::Builder::todo
11136µs528µsTest::Builder::::resetTest::Builder::reset
44134µs40µsTest::Builder::::_autoflushTest::Builder::_autoflush
22133µs33µsTest::Builder::::CORE:openTest::Builder::CORE:open (opcode)
171127µs27µsTest::Builder::::levelTest::Builder::level
73326µs571µsTest::Builder::::newTest::Builder::new
21124µs36µsTest::Builder::::_apply_layersTest::Builder::_apply_layers
11124µs372µsTest::Builder::::_open_testhandlesTest::Builder::_open_testhandles
112124µs24µsTest::Builder::::CORE:substTest::Builder::CORE:subst (opcode)
11123µs41µsTest::Builder::::BEGIN@1466Test::Builder::BEGIN@1466
11122µs54µsTest::Builder::::BEGIN@1278Test::Builder::BEGIN@1278
11122µs133µsTest::Builder::::expected_testsTest::Builder::expected_tests
11121µs479µsTest::Builder::::_dup_stdhandlesTest::Builder::_dup_stdhandles
22120µs315µsTest::Builder::::_copy_io_layersTest::Builder::_copy_io_layers
72120µs29µsTest::Builder::::outputTest::Builder::output
11120µs26µsTest::Builder::::BEGIN@18Test::Builder::BEGIN@18
11118µs37µsTest::Builder::::BEGIN@959Test::Builder::BEGIN@959
101117µs17µsTest::Builder::::__ANON__[:914]Test::Builder::__ANON__[:914]
11117µs104µsTest::Builder::::_output_planTest::Builder::_output_plan
11117µs17µsTest::Builder::::BEGIN@3Test::Builder::BEGIN@3
11116µs545µsTest::Builder::::createTest::Builder::create
61116µs16µsTest::Builder::::_indentTest::Builder::_indent
84115µs15µsTest::Builder::::__ANON__[:66]Test::Builder::__ANON__[:66]
51115µs15µsTest::Builder::::use_numbersTest::Builder::use_numbers
21115µs674µsTest::Builder::::is_eqTest::Builder::is_eq
11115µs29µsTest::Builder::::BEGIN@2243Test::Builder::BEGIN@2243
22214µs155µsTest::Builder::::planTest::Builder::plan
33113µs19µsTest::Builder::::_new_fhTest::Builder::_new_fh
51113µs13µsTest::Builder::::has_planTest::Builder::has_plan
11112µs46µsTest::Builder::::reset_outputsTest::Builder::reset_outputs
11112µs32µsTest::Builder::::BEGIN@1662Test::Builder::BEGIN@1662
101111µs11µsTest::Builder::::__ANON__[:930]Test::Builder::__ANON__[:930]
21111µs11µsTest::Builder::::CORE:binmodeTest::Builder::CORE:binmode (opcode)
1119µs14µsTest::Builder::::BEGIN@5Test::Builder::BEGIN@5
1118µs28µsTest::Builder::::BEGIN@4Test::Builder::BEGIN@4
5118µs8µsTest::Builder::::__ANON__[:67]Test::Builder::__ANON__[:67]
2218µs8µsTest::Builder::::__ANON__[:1660]Test::Builder::__ANON__[:1660]
1118µs141µsTest::Builder::::_plan_testsTest::Builder::_plan_tests
1117µs8µsTest::Builder::::_share_keysTest::Builder::_share_keys
1116µs57µsTest::Builder::::ENDTest::Builder::END
1115µs5µsTest::Builder::::exported_toTest::Builder::exported_to
3115µs5µsTest::Builder::::is_fhTest::Builder::is_fh
1115µs11µsTest::Builder::::failure_outputTest::Builder::failure_output
8215µs5µsTest::Builder::::CORE:selectTest::Builder::CORE:select (opcode)
1115µs5µsTest::Builder::::BEGIN@10Test::Builder::BEGIN@10
1115µs10µsTest::Builder::::todo_outputTest::Builder::todo_output
1113µs3µsTest::Builder::::_my_exitTest::Builder::_my_exit
1113µs3µsTest::Builder::::is_passingTest::Builder::is_passing
0000s0sTest::Builder::::BAIL_OUTTest::Builder::BAIL_OUT
0000s0sTest::Builder::::DESTROYTest::Builder::DESTROY
0000s0sTest::Builder::::__ANON__[:1774]Test::Builder::__ANON__[:1774]
0000s0sTest::Builder::::__ANON__[:261]Test::Builder::__ANON__[:261]
0000s0sTest::Builder::::__ANON__[:61]Test::Builder::__ANON__[:61]
0000s0sTest::Builder::::_caller_contextTest::Builder::_caller_context
0000s0sTest::Builder::::_cmp_diagTest::Builder::_cmp_diag
0000s0sTest::Builder::::_copyTest::Builder::_copy
0000s0sTest::Builder::::_diag_fhTest::Builder::_diag_fh
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::::_print_commentTest::Builder::_print_comment
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::::current_testTest::Builder::current_test
0000s0sTest::Builder::::detailsTest::Builder::details
0000s0sTest::Builder::::diagTest::Builder::diag
0000s0sTest::Builder::::done_testingTest::Builder::done_testing
0000s0sTest::Builder::::explainTest::Builder::explain
0000s0sTest::Builder::::finalizeTest::Builder::finalize
0000s0sTest::Builder::::is_numTest::Builder::is_num
0000s0sTest::Builder::::isnt_eqTest::Builder::isnt_eq
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
3249µs117µs
# spent 17µs within Test::Builder::BEGIN@3 which was called: # once (17µs+0s) by Test::Builder::Module::BEGIN@5 at line 3
use 5.006;
# spent 17µs making 1 call to Test::Builder::BEGIN@3
4226µs247µs
# spent 28µs (8+19) within Test::Builder::BEGIN@4 which was called: # once (8µs+19µs) by Test::Builder::Module::BEGIN@5 at line 4
use strict;
# spent 28µs making 1 call to Test::Builder::BEGIN@4 # spent 19µs making 1 call to strict::import
5257µs219µs
# spent 14µs (9+5) within Test::Builder::BEGIN@5 which was called: # once (9µs+5µs) by Test::Builder::Module::BEGIN@5 at line 5
use warnings;
# spent 14µs making 1 call to Test::Builder::BEGIN@5 # spent 5µs making 1 call to warnings::import
6
71900nsour $VERSION = '1.001002';
8120µs$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
# spent 3µs executing statements in string eval
9
10
# spent 5µs within Test::Builder::BEGIN@10 which was called: # once (5µs+0s) by Test::Builder::Module::BEGIN@5 at line 14
BEGIN {
1116µs if( $] < 5.008 ) {
12 require Test::Builder::IO::Scalar;
13 }
14122µs15µs}
# spent 5µs making 1 call to Test::Builder::BEGIN@10
15
16
17# Make Test::Builder thread-safe for ithreads.
18
# spent 26µs (20+6) within Test::Builder::BEGIN@18 which was called: # once (20µs+6µs) by Test::Builder::Module::BEGIN@5 at line 69
BEGIN {
192328µs21.54ms
# spent 1.53ms (643µs+884µs) within Test::Builder::BEGIN@19 which was called: # once (643µs+884µs) by Test::Builder::Module::BEGIN@5 at line 19
use Config;
# spent 1.53ms making 1 call to Test::Builder::BEGIN@19 # spent 15µ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.
22114µs16µs if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
# spent 6µ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 {
66930µs
# spent 15µs within Test::Builder::__ANON__[/home/ss5/perl5/perlbrew/perls/tapper-perl/lib/5.16.3/Test/Builder.pm:66] which was called 8 times, avg 2µs/call: # 5 times (11µs+0s) by Test::Builder::ok at line 838, avg 2µs/call # once (2µs+0s) by Test::Builder::reset at line 449 # once (1µs+0s) by Test::Builder::_ending at line 2512 # once (800ns+0s) by Test::Builder::_share_keys at line 479
*share = sub { return $_[0] };
67620µs
# spent 8µs within Test::Builder::__ANON__[/home/ss5/perl5/perlbrew/perls/tapper-perl/lib/5.16.3/Test/Builder.pm:67] which was called 5 times, avg 2µs/call: # 5 times (8µs+0s) by Test::Builder::ok at line 818, avg 2µs/call
*lock = sub { 0 };
68 }
6912.77ms126µs}
# spent 26µ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
11916µs1554µsour $Test = Test::Builder->new;
# spent 554µs making 1 call to Test::Builder::new
120
121
# spent 571µs (26+545) within Test::Builder::new which was called 7 times, avg 82µs/call: # 5 times (13µs+0s) by Test::Builder::Module::builder at line 170 of Test/Builder/Module.pm, avg 3µs/call # once (9µs+545µs) by Test::Builder::Module::BEGIN@5 at line 119 # once (4µs+0s) by main::BEGIN@7 at line 19 of Test/Deep.pm
sub new {
12276µs my($class) = shift;
12376µs1545µs $Test ||= $class->create;
# spent 545µs making 1 call to Test::Builder::create
124731µs 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 545µs (16+528) within Test::Builder::create which was called: # once (16µs+528µs) by Test::Builder::new at line 123
sub create {
1421700ns my $class = shift;
143
14417µs my $self = bless {}, $class;
14512µs1528µs $self->reset;
# spent 528µs making 1 call to Test::Builder::reset
146
14713µs return $self;
148}
149
150
151# Copy an object, currently a shallow.
152# This does *not* bless the destination. This keeps the destructor from
153# firing when we're just storing a copy of the object to restore later.
154sub _copy {
155 my($src, $dest) = @_;
156
157 %$dest = %$src;
158 _share_keys($dest);
159
160 return;
161}
162
163
164=item B<child>
165
166 my $child = $builder->child($name_of_child);
167 $child->plan( tests => 4 );
168 $child->ok(some_code());
169 ...
170 $child->finalize;
171
172Returns a new instance of C<Test::Builder>. Any output from this child will
173be indented four spaces more than the parent's indentation. When done, the
174C<finalize> method I<must> be called explicitly.
175
176Trying to create a new child with a previous child still active (i.e.,
177C<finalize> not called) will C<croak>.
178
179Trying to run a test when you have an open child will also C<croak> and cause
180the test suite to fail.
181
182=cut
183
184sub child {
185 my( $self, $name ) = @_;
186
187 if( $self->{Child_Name} ) {
188 $self->croak("You already have a child named ($self->{Child_Name}) running");
189 }
190
191 my $parent_in_todo = $self->in_todo;
192
193 # Clear $TODO for the child.
194 my $orig_TODO = $self->find_TODO(undef, 1, undef);
195
196 my $class = ref $self;
197 my $child = $class->create;
198
199 # Add to our indentation
200 $child->_indent( $self->_indent . ' ' );
201
202 # Make the child use the same outputs as the parent
203 for my $method (qw(output failure_output todo_output)) {
204 $child->$method( $self->$method );
205 }
206
207 # Ensure the child understands if they're inside a TODO
208 if( $parent_in_todo ) {
209 $child->failure_output( $self->todo_output );
210 }
211
212 # This will be reset in finalize. We do this here lest one child failure
213 # cause all children to fail.
214 $child->{Child_Error} = $?;
215 $? = 0;
216 $child->{Parent} = $self;
217 $child->{Parent_TODO} = $orig_TODO;
218 $child->{Name} = $name || "Child of " . $self->name;
219 $self->{Child_Name} = $child->name;
220 return $child;
221}
222
223
224=item B<subtest>
225
226 $builder->subtest($name, \&subtests);
227
228See documentation of C<subtest> in Test::More.
229
230=cut
231
232sub subtest {
233 my $self = shift;
234 my($name, $subtests) = @_;
235
236 if ('CODE' ne ref $subtests) {
237 $self->croak("subtest()'s second argument must be a code ref");
238 }
239
240 # Turn the child into the parent so anyone who has stored a copy of
241 # the Test::Builder singleton will get the child.
242 my $error;
243 my $child;
244 my $parent = {};
245 {
246 # child() calls reset() which sets $Level to 1, so we localize
247 # $Level first to limit the scope of the reset to the subtest.
248 local $Test::Builder::Level = $Test::Builder::Level + 1;
249
250 # Store the guts of $self as $parent and turn $child into $self.
251 $child = $self->child($name);
252 _copy($self, $parent);
253 _copy($child, $self);
254
255 my $run_the_subtests = sub {
256 # Add subtest name for clarification of starting point
257 $self->note("Subtest: $name");
258 $subtests->();
259 $self->done_testing unless $self->_plan_handled;
260 1;
261 };
262
263 if( !eval { $run_the_subtests->() } ) {
264 $error = $@;
265 }
266 }
267
268 # Restore the parent and the copied child.
269 _copy($self, $child);
270 _copy($parent, $self);
271
272 # Restore the parent's $TODO
273 $self->find_TODO(undef, 1, $child->{Parent_TODO});
274
275 # Die *after* we restore the parent.
276 die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
277
278 local $Test::Builder::Level = $Test::Builder::Level + 1;
279 my $finalize = $child->finalize;
280
281 $self->BAIL_OUT($child->{Bailed_Out_Reason}) if $child->{Bailed_Out};
282
283 return $finalize;
284}
285
286=begin _private
287
288=item B<_plan_handled>
289
290 if ( $Test->_plan_handled ) { ... }
291
292Returns true if the developer has explicitly handled the plan via:
293
294=over 4
295
296=item * Explicitly setting the number of tests
297
298=item * Setting 'no_plan'
299
300=item * Set 'skip_all'.
301
302=back
303
304This is currently used in subtests when we implicitly call C<< $Test->done_testing >>
305if the developer has not set a plan.
306
307=end _private
308
309=cut
310
311sub _plan_handled {
312 my $self = shift;
313 return $self->{Have_Plan} || $self->{No_Plan} || $self->{Skip_All};
314}
315
316
317=item B<finalize>
318
319 my $ok = $child->finalize;
320
321When your child is done running tests, you must call C<finalize> to clean up
322and tell the parent your pass/fail status.
323
324Calling finalize on a child with open children will C<croak>.
325
326If the child falls out of scope before C<finalize> is called, a failure
327diagnostic will be issued and the child is considered to have failed.
328
329No attempt to call methods on a child after C<finalize> is called is
330guaranteed to succeed.
331
332Calling this on the root builder is a no-op.
333
334=cut
335
336sub finalize {
337 my $self = shift;
338
339 return unless $self->parent;
340 if( $self->{Child_Name} ) {
341 $self->croak("Can't call finalize() with child ($self->{Child_Name}) active");
342 }
343
344 local $? = 0; # don't fail if $subtests happened to set $? nonzero
345 $self->_ending;
346
347 # XXX This will only be necessary for TAP envelopes (we think)
348 #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );
349
350 local $Test::Builder::Level = $Test::Builder::Level + 1;
351 my $ok = 1;
352 $self->parent->{Child_Name} = undef;
353 unless ($self->{Bailed_Out}) {
354 if ( $self->{Skip_All} ) {
355 $self->parent->skip($self->{Skip_All});
356 }
357 elsif ( not @{ $self->{Test_Results} } ) {
358 $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name );
359 }
360 else {
361 $self->parent->ok( $self->is_passing, $self->name );
362 }
363 }
364 $? = $self->{Child_Error};
365 delete $self->{Parent};
366
367 return $self->is_passing;
368}
369
370
# spent 16µs within Test::Builder::_indent which was called 6 times, avg 3µs/call: # 6 times (16µs+0s) by Test::Builder::_print_to_fh at line 1810, avg 3µs/call
sub _indent {
37162µs my $self = shift;
372
37362µs if( @_ ) {
374 $self->{Indent} = shift;
375 }
376
377620µs return $self->{Indent};
378}
379
380=item B<parent>
381
382 if ( my $parent = $builder->parent ) {
383 ...
384 }
385
386Returns the parent C<Test::Builder> instance, if any. Only used with child
387builders for nested TAP.
388
389=cut
390
391sub parent { shift->{Parent} }
392
393=item B<name>
394
395 diag $builder->name;
396
397Returns the name of the current builder. Top level builders default to C<$0>
398(the name of the executable). Child builders are named via the C<child>
399method. If no name is supplied, will be named "Child of $parent->name".
400
401=cut
402
403sub name { shift->{Name} }
404
405sub DESTROY {
406 my $self = shift;
407 if ( $self->parent and $$ == $self->{Original_Pid} ) {
408 my $name = $self->name;
409 $self->diag(<<"FAIL");
410Child ($name) exited without calling finalize()
411FAIL
412 $self->parent->{In_Destroy} = 1;
413 $self->parent->ok(0, $name);
414 }
415}
416
417=item B<reset>
418
419 $Test->reset;
420
421Reinitializes the Test::Builder singleton to its original state.
422Mostly useful for tests run in persistent environments where the same
423test might be run multiple times in the same process.
424
425=cut
426
4271100nsour $Level;
428
429
# spent 528µs (36+492) within Test::Builder::reset which was called: # once (36µs+492µs) by Test::Builder::create at line 145
sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
4301900ns my($self) = @_;
431
432 # We leave this a global because it has to be localized and localizing
433 # hash keys is just asking for pain. Also, it was documented.
4341600ns $Level = 1;
435
43612µs $self->{Name} = $0;
43711µs13µs $self->is_passing(1);
# spent 3µs making 1 call to Test::Builder::is_passing
4381500ns $self->{Ending} = 0;
4391500ns $self->{Have_Plan} = 0;
4401500ns $self->{No_Plan} = 0;
4411400ns $self->{Have_Output_Plan} = 0;
4421400ns $self->{Done_Testing} = 0;
443
44413µs $self->{Original_Pid} = $$;
4451900ns $self->{Child_Name} = undef;
4461800ns $self->{Indent} ||= '';
447
4481600ns $self->{Curr_Test} = 0;
44913µs12µs $self->{Test_Results} = &share( [] );
# spent 2µs making 1 call to Test::Builder::__ANON__[Test/Builder.pm:66]
450
4511300ns $self->{Exported_To} = undef;
4521300ns $self->{Expected_Tests} = 0;
453
4541300ns $self->{Skip_All} = 0;
455
45611µs $self->{Use_Nums} = 1;
457
4581400ns $self->{No_Header} = 0;
4591500ns $self->{No_Ending} = 0;
460
4611300ns $self->{Todo} = undef;
4621500ns $self->{Todo_Stack} = [];
4631300ns $self->{Start_Todo} = 0;
4641300ns $self->{Opened_Testhandles} = 0;
465
46613µs18µs $self->_share_keys;
# spent 8µs making 1 call to Test::Builder::_share_keys
46711µs1479µs $self->_dup_stdhandles;
# spent 479µs making 1 call to Test::Builder::_dup_stdhandles
468
46916µs return;
470}
471
472
473# Shared scalar values are lost when a hash is copied, so we have
474# a separate method to restore them.
475# Shared references are retained across copies.
476
# spent 8µs (7+800ns) within Test::Builder::_share_keys which was called: # once (7µs+800ns) by Test::Builder::reset at line 466
sub _share_keys {
4771400ns my $self = shift;
478
47911µs1800ns share( $self->{Curr_Test} );
# spent 800ns making 1 call to Test::Builder::__ANON__[Test/Builder.pm:66]
480
48114µs return;
482}
483
484
485=back
486
487=head2 Setting up tests
488
489These methods are for setting up tests and declaring how many there
490are. You usually only want to call one of these methods.
491
492=over 4
493
494=item B<plan>
495
496 $Test->plan('no_plan');
497 $Test->plan( skip_all => $reason );
498 $Test->plan( tests => $num_tests );
499
500A convenient way to set up your tests. Call this and Test::Builder
501will print the appropriate headers and take the appropriate actions.
502
503If you call C<plan()>, don't call any of the other methods below.
504
505If a child calls "skip_all" in the plan, a C<Test::Builder::Exception> is
506thrown. Trap this error, call C<finalize()> and don't run any more tests on
507the child.
508
509 my $child = $Test->child('some child');
510 eval { $child->plan( $condition ? ( skip_all => $reason ) : ( tests => 3 ) ) };
511 if ( eval { $@->isa('Test::Builder::Exception') } ) {
512 $child->finalize;
513 return;
514 }
515 # run your tests
516
517=cut
518
51913µsmy %plan_cmds = (
520 no_plan => \&no_plan,
521 skip_all => \&skip_all,
522 tests => \&_plan_tests,
523);
524
525
# spent 155µs (14+141) within Test::Builder::plan which was called 2 times, avg 77µs/call: # once (11µs+141µs) by Test::More::plan at line 168 of Test/More.pm # once (3µs+0s) by Test::Builder::Module::import at line 91 of Test/Builder/Module.pm
sub plan {
52622µs my( $self, $cmd, $arg ) = @_;
527
52824µs return unless $cmd;
529
5301800ns local $Level = $Level + 1;
531
5321800ns $self->croak("You tried to plan twice") if $self->{Have_Plan};
533
53411µs if( my $method = $plan_cmds{$cmd} ) {
5351400ns local $Level = $Level + 1;
53612µs1141µs $self->$method($arg);
# spent 141µs making 1 call to Test::Builder::_plan_tests
537 }
538 else {
539 my @args = grep { defined } ( $cmd, $arg );
540 $self->croak("plan() doesn't understand @args");
541 }
542
54313µs return 1;
544}
545
546
547
# spent 141µs (8+133) within Test::Builder::_plan_tests which was called: # once (8µs+133µs) by Test::Builder::plan at line 536
sub _plan_tests {
54811µs my($self, $arg) = @_;
549
5501300ns if($arg) {
5511500ns local $Level = $Level + 1;
55216µs1133µs return $self->expected_tests($arg);
# spent 133µs making 1 call to Test::Builder::expected_tests
553 }
554 elsif( !defined $arg ) {
555 $self->croak("Got an undefined number of tests");
556 }
557 else {
558 $self->croak("You said to run 0 tests");
559 }
560
561 return;
562}
563
564=item B<expected_tests>
565
566 my $max = $Test->expected_tests;
567 $Test->expected_tests($max);
568
569Gets/sets the number of tests we expect this test to run and prints out
570the appropriate headers.
571
572=cut
573
574
# spent 133µs (22+112) within Test::Builder::expected_tests which was called: # once (22µs+112µs) by Test::Builder::_plan_tests at line 552
sub expected_tests {
5751500ns my $self = shift;
5761700ns my($max) = @_;
577
5781700ns if(@_) {
579111µs14µs $self->croak("Number of tests must be a positive integer. You gave it '$max'")
# spent 4µs making 1 call to Test::Builder::CORE:match
580 unless $max =~ /^\+?\d+$/;
581
58211µs $self->{Expected_Tests} = $max;
5831500ns $self->{Have_Plan} = 1;
584
58516µs2108µs $self->_output_plan($max) unless $self->no_header;
# spent 104µs making 1 call to Test::Builder::_output_plan # spent 4µs making 1 call to Test::Builder::__ANON__[Test/Builder.pm:1660]
586 }
58713µs return $self->{Expected_Tests};
588}
589
590=item B<no_plan>
591
592 $Test->no_plan;
593
594Declares that this test will run an indeterminate number of tests.
595
596=cut
597
598sub no_plan {
599 my($self, $arg) = @_;
600
601 $self->carp("no_plan takes no arguments") if $arg;
602
603 $self->{No_Plan} = 1;
604 $self->{Have_Plan} = 1;
605
606 return 1;
607}
608
609=begin private
610
611=item B<_output_plan>
612
613 $tb->_output_plan($max);
614 $tb->_output_plan($max, $directive);
615 $tb->_output_plan($max, $directive => $reason);
616
617Handles displaying the test plan.
618
619If a C<$directive> and/or C<$reason> are given they will be output with the
620plan. So here's what skipping all tests looks like:
621
622 $tb->_output_plan(0, "SKIP", "Because I said so");
623
624It sets C<< $tb->{Have_Output_Plan} >> and will croak if the plan was already
625output.
626
627=end private
628
629=cut
630
631
# spent 104µs (17+87) within Test::Builder::_output_plan which was called: # once (17µs+87µs) by Test::Builder::expected_tests at line 585
sub _output_plan {
63211µs my($self, $max, $directive, $reason) = @_;
633
6341700ns $self->carp("The plan was already output") if $self->{Have_Output_Plan};
635
6361900ns my $plan = "1..$max";
6371300ns $plan .= " # $directive" if defined $directive;
6381300ns $plan .= " $reason" if defined $reason;
639
64012µs187µs $self->_print("$plan\n");
# spent 87µs making 1 call to Test::Builder::_print
641
6421800ns $self->{Have_Output_Plan} = 1;
643
64414µs return;
645}
646
647
648=item B<done_testing>
649
650 $Test->done_testing();
651 $Test->done_testing($num_tests);
652
653Declares that you are done testing, no more tests will be run after this point.
654
655If a plan has not yet been output, it will do so.
656
657$num_tests is the number of tests you planned to run. If a numbered
658plan was already declared, and if this contradicts, a failing test
659will be run to reflect the planning mistake. If C<no_plan> was declared,
660this will override.
661
662If C<done_testing()> is called twice, the second call will issue a
663failing test.
664
665If C<$num_tests> is omitted, the number of tests run will be used, like
666no_plan.
667
668C<done_testing()> is, in effect, used when you'd want to use C<no_plan>, but
669safer. You'd use it like so:
670
671 $Test->ok($a == $b);
672 $Test->done_testing();
673
674Or to plan a variable number of tests:
675
676 for my $test (@tests) {
677 $Test->ok($test);
678 }
679 $Test->done_testing(scalar @tests);
680
681=cut
682
683sub done_testing {
684 my($self, $num_tests) = @_;
685
686 # If done_testing() specified the number of tests, shut off no_plan.
687 if( defined $num_tests ) {
688 $self->{No_Plan} = 0;
689 }
690 else {
691 $num_tests = $self->current_test;
692 }
693
694 if( $self->{Done_Testing} ) {
695 my($file, $line) = @{$self->{Done_Testing}}[1,2];
696 $self->ok(0, "done_testing() was already called at $file line $line");
697 return;
698 }
699
700 $self->{Done_Testing} = [caller];
701
702 if( $self->expected_tests && $num_tests != $self->expected_tests ) {
703 $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
704 "but done_testing() expects $num_tests");
705 }
706 else {
707 $self->{Expected_Tests} = $num_tests;
708 }
709
710 $self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
711
712 $self->{Have_Plan} = 1;
713
714 # The wrong number of tests were run
715 $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test};
716
717 # No tests were run
718 $self->is_passing(0) if $self->{Curr_Test} == 0;
719
720 return 1;
721}
722
723
724=item B<has_plan>
725
726 $plan = $Test->has_plan
727
728Find out whether a plan has been defined. C<$plan> is either C<undef> (no plan
729has been set), C<no_plan> (indeterminate # of tests) or an integer (the number
730of expected tests).
731
732=cut
733
734
# spent 13µs within Test::Builder::has_plan which was called 5 times, avg 3µs/call: # 5 times (13µs+0s) by Test::Builder::_check_is_passing_plan at line 903, avg 3µs/call
sub has_plan {
73552µs my $self = shift;
736
737519µs return( $self->{Expected_Tests} ) if $self->{Expected_Tests};
738 return('no_plan') if $self->{No_Plan};
739 return(undef);
740}
741
742=item B<skip_all>
743
744 $Test->skip_all;
745 $Test->skip_all($reason);
746
747Skips all the tests, using the given C<$reason>. Exits immediately with 0.
748
749=cut
750
751sub skip_all {
752 my( $self, $reason ) = @_;
753
754 $self->{Skip_All} = $self->parent ? $reason : 1;
755
756 $self->_output_plan(0, "SKIP", $reason) unless $self->no_header;
757 if ( $self->parent ) {
758 die bless {} => 'Test::Builder::Exception';
759 }
760 exit(0);
761}
762
763=item B<exported_to>
764
765 my $pack = $Test->exported_to;
766 $Test->exported_to($pack);
767
768Tells Test::Builder what package you exported your functions to.
769
770This method isn't terribly useful since modules which share the same
771Test::Builder object might get exported to different packages and only
772the last one will be honored.
773
774=cut
775
776
# spent 5µs within Test::Builder::exported_to which was called: # once (5µs+0s) by Test::Builder::Module::import at line 86 of Test/Builder/Module.pm
sub exported_to {
77711µs my( $self, $pack ) = @_;
778
77911µs if( defined $pack ) {
780 $self->{Exported_To} = $pack;
781 }
78215µs return $self->{Exported_To};
783}
784
785=back
786
787=head2 Running tests
788
789These actually run the tests, analogous to the functions in Test::More.
790
791They all return true if the test passed, false if the test failed.
792
793C<$name> is always optional.
794
795=over 4
796
797=item B<ok>
798
799 $Test->ok($test, $name);
800
801Your basic test. Pass if C<$test> is true, fail if $test is false. Just
802like Test::Simple's C<ok()>.
803
804=cut
805
806
# spent 1.60ms (291µs+1.31) within Test::Builder::ok which was called 5 times, avg 320µs/call: # 2 times (131µs+605µs) by Test::Deep::cmp_deeply at line 150 of Test/Deep.pm, avg 368µs/call # 2 times (82µs+424µs) by Test::Builder::cmp_ok at line 1179, avg 253µs/call # once (77µs+280µs) by Test::More::use_ok at line 968 of Test/More.pm
sub ok {
80756µs my( $self, $test, $name ) = @_;
808
80956µs if ( $self->{Child_Name} and not $self->{In_Destroy} ) {
810 $name = 'unnamed test' unless defined $name;
811 $self->is_passing(0);
812 $self->croak("Cannot run test ($name) with active children");
813 }
814 # $test might contain an object which we don't want to accidentally
815 # store, so we turn it into a boolean.
81653µs $test = $test ? 1 : 0;
817
818510µs58µs lock $self->{Curr_Test};
# spent 8µs making 5 calls to Test::Builder::__ANON__[Test/Builder.pm:67], avg 2µs/call
81954µs $self->{Curr_Test}++;
820
821 # In case $name is a string overloaded object, force it to stringify.
822511µs5294µs $self->_unoverload_str( \$name );
# spent 294µs making 5 calls to Test::Builder::_unoverload_str, avg 59µs/call
823
824538µs523µs $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
# spent 23µs making 5 calls to Test::Builder::CORE:match, avg 5µs/call
825 You named your test '$name'. You shouldn't use numbers for your test names.
826 Very confusing.
827ERR
828
829 # Capture the value of $TODO for the rest of this ok() call
830 # so it can more easily be found by other routines.
831511µs5164µs my $todo = $self->todo();
# spent 164µs making 5 calls to Test::Builder::todo, avg 33µs/call
832510µs5103µs my $in_todo = $self->in_todo;
# spent 103µs making 5 calls to Test::Builder::in_todo, avg 21µs/call
83351µs local $self->{Todo} = $todo if $in_todo;
834
83558µs5231µs $self->_unoverload_str( \$todo );
# spent 231µs making 5 calls to Test::Builder::_unoverload_str, avg 46µs/call
836
83751µs my $out;
838515µs511µs my $result = &share( {} );
# spent 11µs making 5 calls to Test::Builder::__ANON__[Test/Builder.pm:66], avg 2µs/call
839
84054µs unless($test) {
841 $out .= "not ";
842 @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
843 }
844 else {
845513µs @$result{ 'ok', 'actual_ok' } = ( 1, $test );
846 }
847
84854µs $out .= "ok";
849517µs515µs $out .= " $self->{Curr_Test}" if $self->use_numbers;
# spent 15µs making 5 calls to Test::Builder::use_numbers, avg 3µs/call
850
85154µs if( defined $name ) {
852521µs57µs $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
# spent 7µs making 5 calls to Test::Builder::CORE:subst, avg 1µs/call
85355µs $out .= " - $name";
85456µs $result->{name} = $name;
855 }
856 else {
857 $result->{name} = '';
858 }
859
860510µs5115µs if( $self->in_todo ) {
# spent 115µs making 5 calls to Test::Builder::in_todo, avg 23µs/call
861 $out .= " # TODO $todo";
862 $result->{reason} = $todo;
863 $result->{type} = 'todo';
864 }
865 else {
86655µs $result->{reason} = '';
86753µs $result->{type} = '';
868 }
869
87059µs $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
87152µs $out .= "\n";
872
87359µs5275µs $self->_print($out);
# spent 275µs making 5 calls to Test::Builder::_print, avg 55µs/call
874
87552µs unless($test) {
876 my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
877 $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
878
879 my( undef, $file, $line ) = $self->caller;
880 if( defined $name ) {
881 $self->diag(qq[ $msg test '$name'\n]);
882 $self->diag(qq[ at $file line $line.\n]);
883 }
884 else {
885 $self->diag(qq[ $msg test at $file line $line.\n]);
886 }
887 }
888
88951µs $self->is_passing(0) unless $test || $self->in_todo;
890
891 # Check that we haven't violated the plan
892511µs563µs $self->_check_is_passing_plan();
# spent 63µs making 5 calls to Test::Builder::_check_is_passing_plan, avg 13µs/call
893
894521µs return $test ? 1 : 0;
895}
896
897
898# Check that we haven't yet violated the plan and set
899# is_passing() accordingly
900
# spent 63µs (45+18) within Test::Builder::_check_is_passing_plan which was called 5 times, avg 13µs/call: # 5 times (45µs+18µs) by Test::Builder::ok at line 892, avg 13µs/call
sub _check_is_passing_plan {
90152µs my $self = shift;
902
903510µs513µs my $plan = $self->has_plan;
# spent 13µs making 5 calls to Test::Builder::has_plan, avg 3µs/call
90452µs return unless defined $plan; # no plan yet defined
905516µs55µs return unless $plan !~ /\D/; # no numeric plan
# spent 5µs making 5 calls to Test::Builder::CORE:match, avg 980ns/call
906514µs $self->is_passing(0) if $plan < $self->{Curr_Test};
907}
908
909
910
# spent 481µs (140+341) within Test::Builder::_unoverload which was called 10 times, avg 48µs/call: # 10 times (140µs+341µs) by Test::Builder::_unoverload_str at line 936, avg 48µs/call
sub _unoverload {
911103µs my $self = shift;
912103µs my $type = shift;
913
9142086µs10159µs
# spent 17µs within Test::Builder::__ANON__[/home/ss5/perl5/perlbrew/perls/tapper-perl/lib/5.16.3/Test/Builder.pm:914] which was called 10 times, avg 2µs/call: # 10 times (17µs+0s) by Test::Builder::_try at line 1522, avg 2µs/call
$self->_try(sub { require overload; }, die_on_fail => 1);
# spent 159µs making 10 calls to Test::Builder::_try, avg 16µs/call
915
9161011µs foreach my $thing (@_) {
9171042µs10182µs if( $self->_is_object($$thing) ) {
# spent 182µs making 10 calls to Test::Builder::_is_object, avg 18µs/call
918 if( my $string_meth = overload::Method( $$thing, $type ) ) {
919 $$thing = $$thing->$string_meth();
920 }
921 }
922 }
923
9241023µs return;
925}
926
927
# spent 182µs (65+117) within Test::Builder::_is_object which was called 10 times, avg 18µs/call: # 10 times (65µs+117µs) by Test::Builder::_unoverload at line 917, avg 18µs/call
sub _is_object {
928108µs my( $self, $thing ) = @_;
929
9302079µs10117µs
# spent 11µs within Test::Builder::__ANON__[/home/ss5/perl5/perlbrew/perls/tapper-perl/lib/5.16.3/Test/Builder.pm:930] which was called 10 times, avg 1µs/call: # 10 times (11µs+0s) by Test::Builder::_try at line 1522, avg 1µs/call
return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
# spent 117µs making 10 calls to Test::Builder::_try, avg 12µs/call
931}
932
933
# spent 524µs (43+481) within Test::Builder::_unoverload_str which was called 10 times, avg 52µs/call: # 5 times (25µs+269µs) by Test::Builder::ok at line 822, avg 59µs/call # 5 times (18µs+213µs) by Test::Builder::ok at line 835, avg 46µs/call
sub _unoverload_str {
934104µs my $self = shift;
935
9361036µs10481µs return $self->_unoverload( q[""], @_ );
# spent 481µs making 10 calls to Test::Builder::_unoverload, avg 48µs/call
937}
938
939sub _unoverload_num {
940 my $self = shift;
941
942 $self->_unoverload( '0+', @_ );
943
944 for my $val (@_) {
945 next unless $self->_is_dualvar($$val);
946 $$val = $$val + 0;
947 }
948
949 return;
950}
951
952# This is a hack to detect a dualvar such as $!
953sub _is_dualvar {
954 my( $self, $val ) = @_;
955
956 # Objects are not dualvars.
957 return 0 if ref $val;
958
95921.11ms256µs
# spent 37µs (18+19) within Test::Builder::BEGIN@959 which was called: # once (18µs+19µs) by Test::Builder::Module::BEGIN@5 at line 959
no warnings 'numeric';
# spent 37µs making 1 call to Test::Builder::BEGIN@959 # spent 19µs making 1 call to warnings::unimport
960 my $numval = $val + 0;
961 return ($numval != 0 and $numval ne $val ? 1 : 0);
962}
963
964=item B<is_eq>
965
966 $Test->is_eq($got, $expected, $name);
967
968Like Test::More's C<is()>. Checks if C<$got eq $expected>. This is the
969string version.
970
971C<undef> only ever matches another C<undef>.
972
973=item B<is_num>
974
975 $Test->is_num($got, $expected, $name);
976
977Like Test::More's C<is()>. Checks if C<$got == $expected>. This is the
978numeric version.
979
980C<undef> only ever matches another C<undef>.
981
982=cut
983
984
# spent 674µs (15+659) within Test::Builder::is_eq which was called 2 times, avg 337µs/call: # 2 times (15µs+659µs) by Test::More::is at line 376 of Test/More.pm, avg 337µs/call
sub is_eq {
98522µs my( $self, $got, $expect, $name ) = @_;
98622µs local $Level = $Level + 1;
987
98821µs if( !defined $got || !defined $expect ) {
989 # undef only matches undef and nothing else
990 my $test = !defined $got && !defined $expect;
991
992 $self->ok( $test, $name );
993 $self->_is_diag( $got, 'eq', $expect ) unless $test;
994 return $test;
995 }
996
997210µs2659µs return $self->cmp_ok( $got, 'eq', $expect, $name );
# spent 659µs making 2 calls to Test::Builder::cmp_ok, avg 330µs/call
998}
999
1000sub is_num {
1001 my( $self, $got, $expect, $name ) = @_;
1002 local $Level = $Level + 1;
1003
1004 if( !defined $got || !defined $expect ) {
1005 # undef only matches undef and nothing else
1006 my $test = !defined $got && !defined $expect;
1007
1008 $self->ok( $test, $name );
1009 $self->_is_diag( $got, '==', $expect ) unless $test;
1010 return $test;
1011 }
1012
1013 return $self->cmp_ok( $got, '==', $expect, $name );
1014}
1015
1016sub _diag_fmt {
1017 my( $self, $type, $val ) = @_;
1018
1019 if( defined $$val ) {
1020 if( $type eq 'eq' or $type eq 'ne' ) {
1021 # quote and force string context
1022 $$val = "'$$val'";
1023 }
1024 else {
1025 # force numeric context
1026 $self->_unoverload_num($val);
1027 }
1028 }
1029 else {
1030 $$val = 'undef';
1031 }
1032
1033 return;
1034}
1035
1036sub _is_diag {
1037 my( $self, $got, $type, $expect ) = @_;
1038
1039 $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
1040
1041 local $Level = $Level + 1;
1042 return $self->diag(<<"DIAGNOSTIC");
1043 got: $got
1044 expected: $expect
1045DIAGNOSTIC
1046
1047}
1048
1049sub _isnt_diag {
1050 my( $self, $got, $type ) = @_;
1051
1052 $self->_diag_fmt( $type, \$got );
1053
1054 local $Level = $Level + 1;
1055 return $self->diag(<<"DIAGNOSTIC");
1056 got: $got
1057 expected: anything else
1058DIAGNOSTIC
1059}
1060
1061=item B<isnt_eq>
1062
1063 $Test->isnt_eq($got, $dont_expect, $name);
1064
1065Like Test::More's C<isnt()>. Checks if C<$got ne $dont_expect>. This is
1066the string version.
1067
1068=item B<isnt_num>
1069
1070 $Test->isnt_num($got, $dont_expect, $name);
1071
1072Like Test::More's C<isnt()>. Checks if C<$got ne $dont_expect>. This is
1073the numeric version.
1074
1075=cut
1076
1077sub isnt_eq {
1078 my( $self, $got, $dont_expect, $name ) = @_;
1079 local $Level = $Level + 1;
1080
1081 if( !defined $got || !defined $dont_expect ) {
1082 # undef only matches undef and nothing else
1083 my $test = defined $got || defined $dont_expect;
1084
1085 $self->ok( $test, $name );
1086 $self->_isnt_diag( $got, 'ne' ) unless $test;
1087 return $test;
1088 }
1089
1090 return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
1091}
1092
1093sub isnt_num {
1094 my( $self, $got, $dont_expect, $name ) = @_;
1095 local $Level = $Level + 1;
1096
1097 if( !defined $got || !defined $dont_expect ) {
1098 # undef only matches undef and nothing else
1099 my $test = defined $got || defined $dont_expect;
1100
1101 $self->ok( $test, $name );
1102 $self->_isnt_diag( $got, '!=' ) unless $test;
1103 return $test;
1104 }
1105
1106 return $self->cmp_ok( $got, '!=', $dont_expect, $name );
1107}
1108
1109=item B<like>
1110
1111 $Test->like($thing, qr/$regex/, $name);
1112 $Test->like($thing, '/$regex/', $name);
1113
1114Like Test::More's C<like()>. Checks if $thing matches the given C<$regex>.
1115
1116=item B<unlike>
1117
1118 $Test->unlike($thing, qr/$regex/, $name);
1119 $Test->unlike($thing, '/$regex/', $name);
1120
1121Like Test::More's C<unlike()>. Checks if $thing B<does not match> the
1122given C<$regex>.
1123
1124=cut
1125
1126sub like {
1127 my( $self, $thing, $regex, $name ) = @_;
1128
1129 local $Level = $Level + 1;
1130 return $self->_regex_ok( $thing, $regex, '=~', $name );
1131}
1132
1133sub unlike {
1134 my( $self, $thing, $regex, $name ) = @_;
1135
1136 local $Level = $Level + 1;
1137 return $self->_regex_ok( $thing, $regex, '!~', $name );
1138}
1139
1140=item B<cmp_ok>
1141
1142 $Test->cmp_ok($thing, $type, $that, $name);
1143
1144Works just like Test::More's C<cmp_ok()>.
1145
1146 $Test->cmp_ok($big_num, '!=', $other_big_num);
1147
1148=cut
1149
115018µsmy %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
1151
1152# Bad, these are not comparison operators. Should we include more?
115317µsmy %cmp_ok_bl = map { ( $_, 1 ) } ( "=", "+=", ".=", "x=", "^=", "|=", "||=", "&&=", "...");
1154
1155
# spent 659µs (122+537) within Test::Builder::cmp_ok which was called 2 times, avg 330µs/call: # 2 times (122µs+537µs) by Test::Builder::is_eq at line 997, avg 330µs/call
sub cmp_ok {
115623µs my( $self, $got, $type, $expect, $name ) = @_;
1157
115822µs if ($cmp_ok_bl{$type}) {
1159 $self->croak("$type is not a valid comparison operator in cmp_ok()");
1160 }
1161
11622700ns my $test;
11632400ns my $error;
1164 {
1165 ## no critic (BuiltinFunctions::ProhibitStringyEval)
1166
116749µs local( $@, $!, $SIG{__DIE__} ); # isolate eval
1168
116926µs231µs my($pack, $file, $line) = $self->caller();
# spent 31µs making 2 calls to Test::Builder::caller, avg 15µs/call
1170
1171 # This is so that warnings come out at the caller's level
1172269µs $test = eval qq[
1173#line $line "(eval in cmp_ok) $file"
1174\$got $type \$expect;
1175];
117627µs $error = $@;
1177 }
117821µs local $Level = $Level + 1;
117925µs2506µs my $ok = $self->ok( $test, $name );
# spent 506µs making 2 calls to Test::Builder::ok, avg 253µs/call
1180
1181 # Treat overloaded objects as numbers if we're asked to do a
1182 # numeric comparison.
118322µs my $unoverload
1184 = $numeric_cmps{$type}
1185 ? '_unoverload_num'
1186 : '_unoverload_str';
1187
11882600ns $self->diag(<<"END") if $error;
1189An error occurred while using $type:
1190------------------------------------
1191$error
1192------------------------------------
1193END
1194
11952500ns unless($ok) {
1196 $self->$unoverload( \$got, \$expect );
1197
1198 if( $type =~ /^(eq|==)$/ ) {
1199 $self->_is_diag( $got, $type, $expect );
1200 }
1201 elsif( $type =~ /^(ne|!=)$/ ) {
1202 $self->_isnt_diag( $got, $type );
1203 }
1204 else {
1205 $self->_cmp_diag( $got, $type, $expect );
1206 }
1207 }
120826µs return $ok;
1209}
1210
1211sub _cmp_diag {
1212 my( $self, $got, $type, $expect ) = @_;
1213
1214 $got = defined $got ? "'$got'" : 'undef';
1215 $expect = defined $expect ? "'$expect'" : 'undef';
1216
1217 local $Level = $Level + 1;
1218 return $self->diag(<<"DIAGNOSTIC");
1219 $got
1220 $type
1221 $expect
1222DIAGNOSTIC
1223}
1224
1225sub _caller_context {
1226 my $self = shift;
1227
1228 my( $pack, $file, $line ) = $self->caller(1);
1229
1230 my $code = '';
1231 $code .= "#line $line $file\n" if defined $file and defined $line;
1232
1233 return $code;
1234}
1235
1236=back
1237
1238
1239=head2 Other Testing Methods
1240
1241These are methods which are used in the course of writing a test but are not themselves tests.
1242
1243=over 4
1244
1245=item B<BAIL_OUT>
1246
1247 $Test->BAIL_OUT($reason);
1248
1249Indicates to the Test::Harness that things are going so badly all
1250testing should terminate. This includes running any additional test
1251scripts.
1252
1253It will exit with 255.
1254
1255=cut
1256
1257sub BAIL_OUT {
1258 my( $self, $reason ) = @_;
1259
1260 $self->{Bailed_Out} = 1;
1261
1262 if ($self->parent) {
1263 $self->{Bailed_Out_Reason} = $reason;
1264 $self->no_ending(1);
1265 die bless {} => 'Test::Builder::Exception';
1266 }
1267
1268 $self->_print("Bail out! $reason");
1269 exit 255;
1270}
1271
1272=for deprecated
1273BAIL_OUT() used to be BAILOUT()
1274
1275=cut
1276
1277{
12783661µs286µs
# spent 54µs (22+32) within Test::Builder::BEGIN@1278 which was called: # once (22µs+32µs) by Test::Builder::Module::BEGIN@5 at line 1278
no warnings 'once';
# spent 54µs making 1 call to Test::Builder::BEGIN@1278 # spent 32µs making 1 call to warnings::unimport
127912µs *BAILOUT = \&BAIL_OUT;
1280}
1281
1282=item B<skip>
1283
1284 $Test->skip;
1285 $Test->skip($why);
1286
1287Skips the current test, reporting C<$why>.
1288
1289=cut
1290
1291sub skip {
1292 my( $self, $why ) = @_;
1293 $why ||= '';
1294 $self->_unoverload_str( \$why );
1295
1296 lock( $self->{Curr_Test} );
1297 $self->{Curr_Test}++;
1298
1299 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
1300 {
1301 'ok' => 1,
1302 actual_ok => 1,
1303 name => '',
1304 type => 'skip',
1305 reason => $why,
1306 }
1307 );
1308
1309 my $out = "ok";
1310 $out .= " $self->{Curr_Test}" if $self->use_numbers;
1311 $out .= " # skip";
1312 $out .= " $why" if length $why;
1313 $out .= "\n";
1314
1315 $self->_print($out);
1316
1317 return 1;
1318}
1319
1320=item B<todo_skip>
1321
1322 $Test->todo_skip;
1323 $Test->todo_skip($why);
1324
1325Like C<skip()>, only it will declare the test as failing and TODO. Similar
1326to
1327
1328 print "not ok $tnum # TODO $why\n";
1329
1330=cut
1331
1332sub todo_skip {
1333 my( $self, $why ) = @_;
1334 $why ||= '';
1335
1336 lock( $self->{Curr_Test} );
1337 $self->{Curr_Test}++;
1338
1339 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
1340 {
1341 'ok' => 1,
1342 actual_ok => 0,
1343 name => '',
1344 type => 'todo_skip',
1345 reason => $why,
1346 }
1347 );
1348
1349 my $out = "not ok";
1350 $out .= " $self->{Curr_Test}" if $self->use_numbers;
1351 $out .= " # TODO & SKIP $why\n";
1352
1353 $self->_print($out);
1354
1355 return 1;
1356}
1357
1358=begin _unimplemented
1359
1360=item B<skip_rest>
1361
1362 $Test->skip_rest;
1363 $Test->skip_rest($reason);
1364
1365Like C<skip()>, only it skips all the rest of the tests you plan to run
1366and terminates the test.
1367
1368If you're running under C<no_plan>, it skips once and terminates the
1369test.
1370
1371=end _unimplemented
1372
1373=back
1374
1375
1376=head2 Test building utility methods
1377
1378These methods are useful when writing your own test methods.
1379
1380=over 4
1381
1382=item B<maybe_regex>
1383
1384 $Test->maybe_regex(qr/$regex/);
1385 $Test->maybe_regex('/$regex/');
1386
1387This method used to be useful back when Test::Builder worked on Perls
1388before 5.6 which didn't have qr//. Now its pretty useless.
1389
1390Convenience method for building testing functions that take regular
1391expressions as arguments.
1392
1393Takes a quoted regular expression produced by C<qr//>, or a string
1394representing a regular expression.
1395
1396Returns a Perl value which may be used instead of the corresponding
1397regular expression, or C<undef> if its argument is not recognised.
1398
1399For example, a version of C<like()>, sans the useful diagnostic messages,
1400could be written as:
1401
1402 sub laconic_like {
1403 my ($self, $thing, $regex, $name) = @_;
1404 my $usable_regex = $self->maybe_regex($regex);
1405 die "expecting regex, found '$regex'\n"
1406 unless $usable_regex;
1407 $self->ok($thing =~ m/$usable_regex/, $name);
1408 }
1409
1410=cut
1411
1412sub maybe_regex {
1413 my( $self, $regex ) = @_;
1414 my $usable_regex = undef;
1415
1416 return $usable_regex unless defined $regex;
1417
1418 my( $re, $opts );
1419
1420 # Check for qr/foo/
1421 if( _is_qr($regex) ) {
1422 $usable_regex = $regex;
1423 }
1424 # Check for '/foo/' or 'm,foo,'
1425 elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
1426 ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
1427 )
1428 {
1429 $usable_regex = length $opts ? "(?$opts)$re" : $re;
1430 }
1431
1432 return $usable_regex;
1433}
1434
1435sub _is_qr {
1436 my $regex = shift;
1437
1438 # is_regexp() checks for regexes in a robust manner, say if they're
1439 # blessed.
1440 return re::is_regexp($regex) if defined &re::is_regexp;
1441 return ref $regex eq 'Regexp';
1442}
1443
1444sub _regex_ok {
1445 my( $self, $thing, $regex, $cmp, $name ) = @_;
1446
1447 my $ok = 0;
1448 my $usable_regex = $self->maybe_regex($regex);
1449 unless( defined $usable_regex ) {
1450 local $Level = $Level + 1;
1451 $ok = $self->ok( 0, $name );
1452 $self->diag(" '$regex' doesn't look much like a regex to me.");
1453 return $ok;
1454 }
1455
1456 {
1457 my $test;
1458 my $context = $self->_caller_context;
1459
1460 {
1461 ## no critic (BuiltinFunctions::ProhibitStringyEval)
1462
1463 local( $@, $!, $SIG{__DIE__} ); # isolate eval
1464
1465 # No point in issuing an uninit warning, they'll see it in the diagnostics
14662441µs258µs
# spent 41µs (23+18) within Test::Builder::BEGIN@1466 which was called: # once (23µs+18µs) by Test::Builder::Module::BEGIN@5 at line 1466
no warnings 'uninitialized';
# spent 41µs making 1 call to Test::Builder::BEGIN@1466 # spent 18µs making 1 call to warnings::unimport
1467
1468 $test = eval $context . q{$test = $thing =~ /$usable_regex/ ? 1 : 0};
1469 }
1470
1471 $test = !$test if $cmp eq '!~';
1472
1473 local $Level = $Level + 1;
1474 $ok = $self->ok( $test, $name );
1475 }
1476
1477 unless($ok) {
1478 $thing = defined $thing ? "'$thing'" : 'undef';
1479 my $match = $cmp eq '=~' ? "doesn't match" : "matches";
1480
1481 local $Level = $Level + 1;
1482 $self->diag( sprintf <<'DIAGNOSTIC', $thing, $match, $regex );
1483 %s
1484 %13s '%s'
1485DIAGNOSTIC
1486
1487 }
1488
1489 return $ok;
1490}
1491
1492# I'm not ready to publish this. It doesn't deal with array return
1493# values from the code or context.
1494
1495=begin private
1496
1497=item B<_try>
1498
1499 my $return_from_code = $Test->try(sub { code });
1500 my($return_from_code, $error) = $Test->try(sub { code });
1501
1502Works like eval BLOCK except it ensures it has no effect on the rest
1503of the test (ie. C<$@> is not set) nor is effected by outside
1504interference (ie. C<$SIG{__DIE__}>) and works around some quirks in older
1505Perls.
1506
1507C<$error> is what would normally be in C<$@>.
1508
1509It is suggested you use this in place of eval BLOCK.
1510
1511=cut
1512
1513
# spent 571µs (288+284) within Test::Builder::_try which was called 22 times, avg 26µs/call: # 10 times (142µs+17µs) by Test::Builder::_unoverload at line 914, avg 16µs/call # 10 times (105µs+11µs) by Test::Builder::_is_object at line 930, avg 12µs/call # 2 times (40µs+255µs) by Test::Builder::_copy_io_layers at line 1969, avg 147µs/call
sub _try {
15142223µs my( $self, $code, %opts ) = @_;
1515
1516223µs my $error;
1517222µs my $return;
1518 {
15194446µs local $!; # eval can mess up $!
1520224µs local $@; # don't set $@ in the test
15212231µs local $SIG{__DIE__}; # don't trip an outside DIE handler.
15224453µs22284µs $return = eval { $code->() };
# spent 255µs making 2 calls to Test::Builder::__ANON__[Test/Builder.pm:1968], avg 127µs/call # spent 17µs making 10 calls to Test::Builder::__ANON__[Test/Builder.pm:914], avg 2µs/call # spent 11µs making 10 calls to Test::Builder::__ANON__[Test/Builder.pm:930], avg 1µs/call
15232239µs $error = $@;
1524 }
1525
1526224µs die $error if $error and $opts{die_on_fail};
1527
15282274µs return wantarray ? ( $return, $error ) : $return;
1529}
1530
1531=end private
1532
1533
1534=item B<is_fh>
1535
1536 my $is_fh = $Test->is_fh($thing);
1537
1538Determines if the given C<$thing> can be used as a filehandle.
1539
1540=cut
1541
1542
# spent 5µs within Test::Builder::is_fh which was called 3 times, avg 2µs/call: # 3 times (5µs+0s) by Test::Builder::_new_fh at line 1889, avg 2µs/call
sub is_fh {
15433700ns my $self = shift;
15443300ns my $maybe_fh = shift;
15453600ns return 0 unless defined $maybe_fh;
1546
154739µs return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
1548 return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
1549
1550 return eval { $maybe_fh->isa("IO::Handle") } ||
1551 eval { tied($maybe_fh)->can('TIEHANDLE') };
1552}
1553
1554=back
1555
1556
1557=head2 Test style
1558
1559
1560=over 4
1561
1562=item B<level>
1563
1564 $Test->level($how_high);
1565
1566How far up the call stack should C<$Test> look when reporting where the
1567test failed.
1568
1569Defaults to 1.
1570
1571Setting L<$Test::Builder::Level> overrides. This is typically useful
1572localized:
1573
1574 sub my_ok {
1575 my $test = shift;
1576
1577 local $Test::Builder::Level = $Test::Builder::Level + 1;
1578 $TB->ok($test);
1579 }
1580
1581To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant.
1582
1583=cut
1584
1585
# spent 27µs within Test::Builder::level which was called 17 times, avg 2µs/call: # 17 times (27µs+0s) by Test::Builder::caller at line 2366, avg 2µs/call
sub level {
1586176µs my( $self, $level ) = @_;
1587
1588174µs if( defined $level ) {
1589 $Level = $level;
1590 }
15911745µs return $Level;
1592}
1593
1594=item B<use_numbers>
1595
1596 $Test->use_numbers($on_or_off);
1597
1598Whether or not the test should output numbers. That is, this if true:
1599
1600 ok 1
1601 ok 2
1602 ok 3
1603
1604or this if false
1605
1606 ok
1607 ok
1608 ok
1609
1610Most useful when you can't depend on the test output order, such as
1611when threads or forking is involved.
1612
1613Defaults to on.
1614
1615=cut
1616
1617
# spent 15µs within Test::Builder::use_numbers which was called 5 times, avg 3µs/call: # 5 times (15µs+0s) by Test::Builder::ok at line 849, avg 3µs/call
sub use_numbers {
161854µs my( $self, $use_nums ) = @_;
1619
162052µs if( defined $use_nums ) {
1621 $self->{Use_Nums} = $use_nums;
1622 }
1623522µs return $self->{Use_Nums};
1624}
1625
1626=item B<no_diag>
1627
1628 $Test->no_diag($no_diag);
1629
1630If set true no diagnostics will be printed. This includes calls to
1631C<diag()>.
1632
1633=item B<no_ending>
1634
1635 $Test->no_ending($no_ending);
1636
1637Normally, Test::Builder does some extra diagnostics when the test
1638ends. It also changes the exit code as described below.
1639
1640If this is true, none of that will be done.
1641
1642=item B<no_header>
1643
1644 $Test->no_header($no_header);
1645
1646If set to true, no "1..N" header will be printed.
1647
1648=cut
1649
165011µsforeach my $attribute (qw(No_Header No_Ending No_Diag)) {
165132µs my $method = lc $attribute;
1652
1653
# spent 8µs within Test::Builder::__ANON__[/home/ss5/perl5/perlbrew/perls/tapper-perl/lib/5.16.3/Test/Builder.pm:1660] which was called 2 times, avg 4µs/call: # once (4µs+0s) by Test::Builder::_ending at line 2452 # once (4µs+0s) by Test::Builder::expected_tests at line 585
my $code = sub {
165422µs my( $self, $no ) = @_;
1655
16562700ns if( defined $no ) {
1657 $self->{$attribute} = $no;
1658 }
1659210µs return $self->{$attribute};
166035µs };
1661
166221.54ms252µs
# spent 32µs (12+20) within Test::Builder::BEGIN@1662 which was called: # once (12µs+20µs) by Test::Builder::Module::BEGIN@5 at line 1662
no strict 'refs'; ## no critic
# spent 32µs making 1 call to Test::Builder::BEGIN@1662 # spent 20µs making 1 call to strict::unimport
1663311µs *{ __PACKAGE__ . '::' . $method } = $code;
1664}
1665
1666=back
1667
1668=head2 Output
1669
1670Controlling where the test output goes.
1671
1672It's ok for your test to change where STDOUT and STDERR point to,
1673Test::Builder's default output settings will not be affected.
1674
1675=over 4
1676
1677=item B<diag>
1678
1679 $Test->diag(@msgs);
1680
1681Prints out the given C<@msgs>. Like C<print>, arguments are simply
1682appended together.
1683
1684Normally, it uses the C<failure_output()> handle, but if this is for a
1685TODO test, the C<todo_output()> handle is used.
1686
1687Output will be indented and marked with a # so as not to interfere
1688with test output. A newline will be put on the end if there isn't one
1689already.
1690
1691We encourage using this rather than calling print directly.
1692
1693Returns false. Why? Because C<diag()> is often used in conjunction with
1694a failing test (C<ok() || diag()>) it "passes through" the failure.
1695
1696 return ok(...) || diag(...);
1697
1698=for blame transfer
1699Mark Fowler <mark@twoshortplanks.com>
1700
1701=cut
1702
1703sub diag {
1704 my $self = shift;
1705
1706 $self->_print_comment( $self->_diag_fh, @_ );
1707}
1708
1709=item B<note>
1710
1711 $Test->note(@msgs);
1712
1713Like C<diag()>, but it prints to the C<output()> handle so it will not
1714normally be seen by the user except in verbose mode.
1715
1716=cut
1717
1718sub note {
1719 my $self = shift;
1720
1721 $self->_print_comment( $self->output, @_ );
1722}
1723
1724sub _diag_fh {
1725 my $self = shift;
1726
1727 local $Level = $Level + 1;
1728 return $self->in_todo ? $self->todo_output : $self->failure_output;
1729}
1730
1731sub _print_comment {
1732 my( $self, $fh, @msgs ) = @_;
1733
1734 return if $self->no_diag;
1735 return unless @msgs;
1736
1737 # Prevent printing headers when compiling (i.e. -c)
1738 return if $^C;
1739
1740 # Smash args together like print does.
1741 # Convert undef to 'undef' so its readable.
1742 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1743
1744 # Escape the beginning, _print will take care of the rest.
1745 $msg =~ s/^/# /;
1746
1747 local $Level = $Level + 1;
1748 $self->_print_to_fh( $fh, $msg );
1749
1750 return 0;
1751}
1752
1753=item B<explain>
1754
1755 my @dump = $Test->explain(@msgs);
1756
1757Will dump the contents of any references in a human readable format.
1758Handy for things like...
1759
1760 is_deeply($have, $want) || diag explain $have;
1761
1762or
1763
1764 is_deeply($have, $want) || note explain $have;
1765
1766=cut
1767
1768sub explain {
1769 my $self = shift;
1770
1771 return map {
1772 ref $_
1773 ? do {
1774 $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
1775
1776 my $dumper = Data::Dumper->new( [$_] );
1777 $dumper->Indent(1)->Terse(1);
1778 $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
1779 $dumper->Dump;
1780 }
1781 : $_
1782 } @_;
1783}
1784
1785=begin _private
1786
1787=item B<_print>
1788
1789 $Test->_print(@msgs);
1790
1791Prints to the C<output()> filehandle.
1792
1793=end _private
1794
1795=cut
1796
1797
# spent 362µs (45+318) within Test::Builder::_print which was called 6 times, avg 60µs/call: # 5 times (34µs+241µs) by Test::Builder::ok at line 873, avg 55µs/call # once (10µs+76µs) by Test::Builder::_output_plan at line 640
sub _print {
179862µs my $self = shift;
1799641µs12318µs return $self->_print_to_fh( $self->output, @_ );
# spent 303µs making 6 calls to Test::Builder::_print_to_fh, avg 50µs/call # spent 15µs making 6 calls to Test::Builder::output, avg 2µs/call
1800}
1801
1802
# spent 303µs (130+173) within Test::Builder::_print_to_fh which was called 6 times, avg 50µs/call: # 6 times (130µs+173µs) by Test::Builder::_print at line 1799, avg 50µs/call
sub _print_to_fh {
180367µs my( $self, $fh, @msgs ) = @_;
1804
1805 # Prevent printing headers when only compiling. Mostly for when
1806 # tests are deparsed with B::Deparse
180765µs return if $^C;
1808
180967µs my $msg = join '', @msgs;
1810612µs616µs my $indent = $self->_indent;
# spent 16µs making 6 calls to Test::Builder::_indent, avg 3µs/call
1811
1812615µs local( $\, $", $, ) = ( undef, ' ', '' );
1813
1814 # Escape each line after the first with a # so we don't
1815 # confuse Test::Harness.
1816639µs617µs $msg =~ s{\n(?!\z)}{\n$indent# }sg;
# spent 17µs making 6 calls to Test::Builder::CORE:subst, avg 3µs/call
1817
1818 # Stick a newline on the end if it needs it.
1819622µs69µs $msg .= "\n" unless $msg =~ /\n\z/;
# spent 9µs making 6 calls to Test::Builder::CORE:match, avg 2µs/call
1820
18216179µs6132µs return print $fh $indent, $msg;
# spent 132µs making 6 calls to Test::Builder::CORE:print, avg 22µs/call
1822}
1823
1824=item B<output>
1825
1826=item B<failure_output>
1827
1828=item B<todo_output>
1829
1830 my $filehandle = $Test->output;
1831 $Test->output($filehandle);
1832 $Test->output($filename);
1833 $Test->output(\$scalar);
1834
1835These methods control where Test::Builder will print its output.
1836They take either an open C<$filehandle>, a C<$filename> to open and write to
1837or a C<$scalar> reference to append to. It will always return a C<$filehandle>.
1838
1839B<output> is where normal "ok/not ok" test output goes.
1840
1841Defaults to STDOUT.
1842
1843B<failure_output> is where diagnostic output on test failures and
1844C<diag()> goes. It is normally not read by Test::Harness and instead is
1845displayed to the user.
1846
1847Defaults to STDERR.
1848
1849C<todo_output> is used instead of C<failure_output()> for the
1850diagnostics of a failing TODO test. These will not be seen by the
1851user.
1852
1853Defaults to STDOUT.
1854
1855=cut
1856
1857
# spent 29µs (20+8) within Test::Builder::output which was called 7 times, avg 4µs/call: # 6 times (15µs+0s) by Test::Builder::_print at line 1799, avg 2µs/call # once (6µs+8µs) by Test::Builder::reset_outputs at line 1993
sub output {
185875µs my( $self, $fh ) = @_;
1859
186074µs18µs if( defined $fh ) {
# spent 8µs making 1 call to Test::Builder::_new_fh
1861 $self->{Out_FH} = $self->_new_fh($fh);
1862 }
1863721µs return $self->{Out_FH};
1864}
1865
1866
# spent 11µs (5+5) within Test::Builder::failure_output which was called: # once (5µs+5µs) by Test::Builder::reset_outputs at line 1994
sub failure_output {
18671500ns my( $self, $fh ) = @_;
1868
186912µs15µs if( defined $fh ) {
# spent 5µs making 1 call to Test::Builder::_new_fh
1870 $self->{Fail_FH} = $self->_new_fh($fh);
1871 }
187213µs return $self->{Fail_FH};
1873}
1874
1875
# spent 10µs (5+5) within Test::Builder::todo_output which was called: # once (5µs+5µs) by Test::Builder::reset_outputs at line 1995
sub todo_output {
18761400ns my( $self, $fh ) = @_;
1877
187811µs15µs if( defined $fh ) {
# spent 5µs making 1 call to Test::Builder::_new_fh
1879 $self->{Todo_FH} = $self->_new_fh($fh);
1880 }
188114µs return $self->{Todo_FH};
1882}
1883
1884
# spent 19µs (13+5) within Test::Builder::_new_fh which was called 3 times, avg 6µs/call: # once (6µs+2µs) by Test::Builder::output at line 1860 # once (4µs+2µs) by Test::Builder::failure_output at line 1869 # once (4µs+1µs) by Test::Builder::todo_output at line 1878
sub _new_fh {
18853700ns my $self = shift;
18863800ns my($file_or_fh) = shift;
1887
18883300ns my $fh;
188934µs35µs if( $self->is_fh($file_or_fh) ) {
# spent 5µs making 3 calls to Test::Builder::is_fh, avg 2µs/call
1890 $fh = $file_or_fh;
1891 }
1892 elsif( ref $file_or_fh eq 'SCALAR' ) {
1893 # Scalar refs as filehandles was added in 5.8.
1894 if( $] >= 5.008 ) {
1895 open $fh, ">>", $file_or_fh
1896 or $self->croak("Can't open scalar ref $file_or_fh: $!");
1897 }
1898 # Emulate scalar ref filehandles with a tie.
1899 else {
1900 $fh = Test::Builder::IO::Scalar->new($file_or_fh)
1901 or $self->croak("Can't tie scalar ref $file_or_fh");
1902 }
1903 }
1904 else {
1905 open $fh, ">", $file_or_fh
1906 or $self->croak("Can't open test output log $file_or_fh: $!");
1907 _autoflush($fh);
1908 }
1909
191038µs return $fh;
1911}
1912
1913
# spent 40µs (34+5) within Test::Builder::_autoflush which was called 4 times, avg 10µs/call: # once (14µs+2µs) by Test::Builder::_dup_stdhandles at line 1931 # once (9µs+600ns) by Test::Builder::_dup_stdhandles at line 1933 # once (6µs+1µs) by Test::Builder::_dup_stdhandles at line 1932 # once (6µs+1µs) by Test::Builder::_dup_stdhandles at line 1934
sub _autoflush {
191442µs my($fh) = shift;
1915416µs43µs my $old_fh = select $fh;
# spent 3µs making 4 calls to Test::Builder::CORE:select, avg 825ns/call
191642µs $| = 1;
1917415µs42µs select $old_fh;
# spent 2µs making 4 calls to Test::Builder::CORE:select, avg 450ns/call
1918
1919412µs return;
1920}
1921
19221300nsmy( $Testout, $Testerr );
1923
1924
# spent 479µs (21+458) within Test::Builder::_dup_stdhandles which was called: # once (21µs+458µs) by Test::Builder::reset at line 467
sub _dup_stdhandles {
19251300ns my $self = shift;
1926
192711µs1372µs $self->_open_testhandles;
# spent 372µs making 1 call to Test::Builder::_open_testhandles
1928
1929 # Set everything to unbuffered else plain prints to STDOUT will
1930 # come out in the wrong order from our own prints.
193112µs116µs _autoflush($Testout);
# spent 16µs making 1 call to Test::Builder::_autoflush
193212µs18µs _autoflush( \*STDOUT );
# spent 8µs making 1 call to Test::Builder::_autoflush
193311µs110µs _autoflush($Testerr);
# spent 10µs making 1 call to Test::Builder::_autoflush
193411µs17µs _autoflush( \*STDERR );
# spent 7µs making 1 call to Test::Builder::_autoflush
1935
193612µs146µs $self->reset_outputs;
# spent 46µs making 1 call to Test::Builder::reset_outputs
1937
193813µs return;
1939}
1940
1941
# spent 372µs (24+348) within Test::Builder::_open_testhandles which was called: # once (24µs+348µs) by Test::Builder::_dup_stdhandles at line 1927
sub _open_testhandles {
19421200ns my $self = shift;
1943
19441400ns return if $self->{Opened_Testhandles};
1945
1946 # We dup STDOUT and STDERR so people can change them in their
1947 # test suites while still getting normal test output.
1948136µs128µs open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
# spent 28µs making 1 call to Test::Builder::CORE:open
1949110µs15µs open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!";
# spent 5µs making 1 call to Test::Builder::CORE:open
1950
195112µs1270µs $self->_copy_io_layers( \*STDOUT, $Testout );
# spent 270µs making 1 call to Test::Builder::_copy_io_layers
195212µs146µs $self->_copy_io_layers( \*STDERR, $Testerr );
# spent 46µs making 1 call to Test::Builder::_copy_io_layers
1953
19541700ns $self->{Opened_Testhandles} = 1;
1955
195614µs return;
1957}
1958
1959
# spent 315µs (20+295) within Test::Builder::_copy_io_layers which was called 2 times, avg 158µs/call: # once (12µs+258µs) by Test::Builder::_open_testhandles at line 1951 # once (8µs+37µs) by Test::Builder::_open_testhandles at line 1952
sub _copy_io_layers {
196022µs my( $self, $src, $dst ) = @_;
1961
1962 $self->_try(
1963
# spent 255µs (209+46) within Test::Builder::__ANON__[/home/ss5/perl5/perlbrew/perls/tapper-perl/lib/5.16.3/Test/Builder.pm:1968] which was called 2 times, avg 127µs/call: # 2 times (209µs+46µs) by Test::Builder::_try at line 1522, avg 127µs/call
sub {
19642179µs require PerlIO;
1965224µs210µs my @src_layers = PerlIO::get_layers($src);
# spent 10µs making 2 calls to PerlIO::get_layers, avg 5µs/call
1966
196729µs236µs _apply_layers($dst, @src_layers) if @src_layers;
# spent 36µs making 2 calls to Test::Builder::_apply_layers, avg 18µs/call
1968 }
1969212µs2295µs );
# spent 295µs making 2 calls to Test::Builder::_try, avg 147µs/call
1970
197127µs return;
1972}
1973
1974
# spent 36µs (24+11) within Test::Builder::_apply_layers which was called 2 times, avg 18µs/call: # 2 times (24µs+11µs) by Test::Builder::__ANON__[/home/ss5/perl5/perlbrew/perls/tapper-perl/lib/5.16.3/Test/Builder.pm:1968] at line 1967, avg 18µs/call
sub _apply_layers {
197522µs my ($fh, @layers) = @_;
19762300ns my %seen;
197726µs my @unique = grep { $_ ne 'unix' and !$seen{$_}++ } @layers;
1978231µs211µs binmode($fh, join(":", "", "raw", @unique));
# spent 11µs making 2 calls to Test::Builder::CORE:binmode, avg 6µs/call
1979}
1980
1981
1982=item reset_outputs
1983
1984 $tb->reset_outputs;
1985
1986Resets all the output filehandles back to their defaults.
1987
1988=cut
1989
1990
# spent 46µs (12+34) within Test::Builder::reset_outputs which was called: # once (12µs+34µs) by Test::Builder::_dup_stdhandles at line 1936
sub reset_outputs {
19911300ns my $self = shift;
1992
199311µs114µs $self->output ($Testout);
# spent 14µs making 1 call to Test::Builder::output
199411µs111µs $self->failure_output($Testerr);
# spent 11µs making 1 call to Test::Builder::failure_output
199511µs110µs $self->todo_output ($Testout);
# spent 10µs making 1 call to Test::Builder::todo_output
1996
199713µs return;
1998}
1999
2000=item carp
2001
2002 $tb->carp(@message);
2003
2004Warns with C<@message> but the message will appear to come from the
2005point where the original test function was called (C<< $tb->caller >>).
2006
2007=item croak
2008
2009 $tb->croak(@message);
2010
2011Dies with C<@message> but the message will appear to come from the
2012point where the original test function was called (C<< $tb->caller >>).
2013
2014=cut
2015
2016sub _message_at_caller {
2017 my $self = shift;
2018
2019 local $Level = $Level + 1;
2020 my( $pack, $file, $line ) = $self->caller;
2021 return join( "", @_ ) . " at $file line $line.\n";
2022}
2023
2024sub carp {
2025 my $self = shift;
2026 return warn $self->_message_at_caller(@_);
2027}
2028
2029sub croak {
2030 my $self = shift;
2031 return die $self->_message_at_caller(@_);
2032}
2033
2034
2035=back
2036
2037
2038=head2 Test Status and Info
2039
2040=over 4
2041
2042=item B<current_test>
2043
2044 my $curr_test = $Test->current_test;
2045 $Test->current_test($num);
2046
2047Gets/sets the current test number we're on. You usually shouldn't
2048have to set this.
2049
2050If set forward, the details of the missing tests are filled in as 'unknown'.
2051if set backward, the details of the intervening tests are deleted. You
2052can erase history if you really want to.
2053
2054=cut
2055
2056sub current_test {
2057 my( $self, $num ) = @_;
2058
2059 lock( $self->{Curr_Test} );
2060 if( defined $num ) {
2061 $self->{Curr_Test} = $num;
2062
2063 # If the test counter is being pushed forward fill in the details.
2064 my $test_results = $self->{Test_Results};
2065 if( $num > @$test_results ) {
2066 my $start = @$test_results ? @$test_results : 0;
2067 for( $start .. $num - 1 ) {
2068 $test_results->[$_] = &share(
2069 {
2070 'ok' => 1,
2071 actual_ok => undef,
2072 reason => 'incrementing test number',
2073 type => 'unknown',
2074 name => undef
2075 }
2076 );
2077 }
2078 }
2079 # If backward, wipe history. Its their funeral.
2080 elsif( $num < @$test_results ) {
2081 $#{$test_results} = $num - 1;
2082 }
2083 }
2084 return $self->{Curr_Test};
2085}
2086
2087=item B<is_passing>
2088
2089 my $ok = $builder->is_passing;
2090
2091Indicates if the test suite is currently passing.
2092
2093More formally, it will be false if anything has happened which makes
2094it impossible for the test suite to pass. True otherwise.
2095
2096For example, if no tests have run C<is_passing()> will be true because
2097even though a suite with no tests is a failure you can add a passing
2098test to it and start passing.
2099
2100Don't think about it too much.
2101
2102=cut
2103
2104
# spent 3µs within Test::Builder::is_passing which was called: # once (3µs+0s) by Test::Builder::reset at line 437
sub is_passing {
21051300ns my $self = shift;
2106
21071800ns if( @_ ) {
2108 $self->{Is_Passing} = shift;
2109 }
2110
211117µs return $self->{Is_Passing};
2112}
2113
2114
2115=item B<summary>
2116
2117 my @tests = $Test->summary;
2118
2119A simple summary of the tests so far. True for pass, false for fail.
2120This is a logical pass/fail, so todos are passes.
2121
2122Of course, test #1 is $tests[0], etc...
2123
2124=cut
2125
2126sub summary {
2127 my($self) = shift;
2128
2129 return map { $_->{'ok'} } @{ $self->{Test_Results} };
2130}
2131
2132=item B<details>
2133
2134 my @tests = $Test->details;
2135
2136Like C<summary()>, but with a lot more detail.
2137
2138 $tests[$test_num - 1] =
2139 { 'ok' => is the test considered a pass?
2140 actual_ok => did it literally say 'ok'?
2141 name => name of the test (if any)
2142 type => type of test (if any, see below).
2143 reason => reason for the above (if any)
2144 };
2145
2146'ok' is true if Test::Harness will consider the test to be a pass.
2147
2148'actual_ok' is a reflection of whether or not the test literally
2149printed 'ok' or 'not ok'. This is for examining the result of 'todo'
2150tests.
2151
2152'name' is the name of the test.
2153
2154'type' indicates if it was a special test. Normal tests have a type
2155of ''. Type can be one of the following:
2156
2157 skip see skip()
2158 todo see todo()
2159 todo_skip see todo_skip()
2160 unknown see below
2161
2162Sometimes the Test::Builder test counter is incremented without it
2163printing any test output, for example, when C<current_test()> is changed.
2164In these cases, Test::Builder doesn't know the result of the test, so
2165its type is 'unknown'. These details for these tests are filled in.
2166They are considered ok, but the name and actual_ok is left C<undef>.
2167
2168For example "not ok 23 - hole count # TODO insufficient donuts" would
2169result in this structure:
2170
2171 $tests[22] = # 23 - 1, since arrays start from 0.
2172 { ok => 1, # logically, the test passed since its todo
2173 actual_ok => 0, # in absolute terms, it failed
2174 name => 'hole count',
2175 type => 'todo',
2176 reason => 'insufficient donuts'
2177 };
2178
2179=cut
2180
2181sub details {
2182 my $self = shift;
2183 return @{ $self->{Test_Results} };
2184}
2185
2186=item B<todo>
2187
2188 my $todo_reason = $Test->todo;
2189 my $todo_reason = $Test->todo($pack);
2190
2191If the current tests are considered "TODO" it will return the reason,
2192if any. This reason can come from a C<$TODO> variable or the last call
2193to C<todo_start()>.
2194
2195Since a TODO test does not need a reason, this function can return an
2196empty string even when inside a TODO block. Use C<< $Test->in_todo >>
2197to determine if you are currently inside a TODO block.
2198
2199C<todo()> is about finding the right package to look for C<$TODO> in. It's
2200pretty good at guessing the right package to look at. It first looks for
2201the caller based on C<$Level + 1>, since C<todo()> is usually called inside
2202a test function. As a last resort it will use C<exported_to()>.
2203
2204Sometimes there is some confusion about where todo() should be looking
2205for the C<$TODO> variable. If you want to be sure, tell it explicitly
2206what $pack to use.
2207
2208=cut
2209
2210
# spent 164µs (39+125) within Test::Builder::todo which was called 5 times, avg 33µs/call: # 5 times (39µs+125µs) by Test::Builder::ok at line 831, avg 33µs/call
sub todo {
221154µs my( $self, $pack ) = @_;
2212
221354µs return $self->{Todo} if defined $self->{Todo};
2214
221554µs local $Level = $Level + 1;
221659µs5125µs my $todo = $self->find_TODO($pack);
# spent 125µs making 5 calls to Test::Builder::find_TODO, avg 25µs/call
221752µs return $todo if defined $todo;
2218
2219514µs return '';
2220}
2221
2222=item B<find_TODO>
2223
2224 my $todo_reason = $Test->find_TODO();
2225 my $todo_reason = $Test->find_TODO($pack);
2226
2227Like C<todo()> but only returns the value of C<$TODO> ignoring
2228C<todo_start()>.
2229
2230Can also be used to set C<$TODO> to a new value while returning the
2231old value:
2232
2233 my $old_reason = $Test->find_TODO($pack, 1, $new_reason);
2234
2235=cut
2236
2237
# spent 294µs (97+197) within Test::Builder::find_TODO which was called 15 times, avg 20µs/call: # 10 times (55µs+114µs) by Test::Builder::in_todo at line 2261, avg 17µs/call # 5 times (42µs+82µs) by Test::Builder::todo at line 2216, avg 25µs/call
sub find_TODO {
2238159µs my( $self, $pack, $set, $new_value ) = @_;
2239
22401523µs15197µs $pack = $pack || $self->caller(1) || $self->exported_to;
# spent 197µs making 15 calls to Test::Builder::caller, avg 13µs/call
2241154µs return unless $pack;
2242
224321.01ms244µs
# spent 29µs (15+15) within Test::Builder::BEGIN@2243 which was called: # once (15µs+15µs) by Test::Builder::Module::BEGIN@5 at line 2243
no strict 'refs'; ## no critic
# spent 29µs making 1 call to Test::Builder::BEGIN@2243 # spent 15µs making 1 call to strict::unimport
22441518µs my $old_value = ${ $pack . '::TODO' };
2245152µs $set and ${ $pack . '::TODO' } = $new_value;
22461537µs return $old_value;
2247}
2248
2249=item B<in_todo>
2250
2251 my $in_todo = $Test->in_todo;
2252
2253Returns true if the test is currently inside a TODO block.
2254
2255=cut
2256
2257
# spent 218µs (49+170) within Test::Builder::in_todo which was called 10 times, avg 22µs/call: # 5 times (22µs+93µs) by Test::Builder::ok at line 860, avg 23µs/call # 5 times (26µs+77µs) by Test::Builder::ok at line 832, avg 21µs/call
sub in_todo {
2258104µs my $self = shift;
2259
2260106µs local $Level = $Level + 1;
22611037µs10170µs return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
# spent 170µs making 10 calls to Test::Builder::find_TODO, avg 17µs/call
2262}
2263
2264=item B<todo_start>
2265
2266 $Test->todo_start();
2267 $Test->todo_start($message);
2268
2269This method allows you declare all subsequent tests as TODO tests, up until
2270the C<todo_end> method has been called.
2271
2272The C<TODO:> and C<$TODO> syntax is generally pretty good about figuring out
2273whether or not we're in a TODO test. However, often we find that this is not
2274possible to determine (such as when we want to use C<$TODO> but
2275the tests are being executed in other packages which can't be inferred
2276beforehand).
2277
2278Note that you can use this to nest "todo" tests
2279
2280 $Test->todo_start('working on this');
2281 # lots of code
2282 $Test->todo_start('working on that');
2283 # more code
2284 $Test->todo_end;
2285 $Test->todo_end;
2286
2287This is generally not recommended, but large testing systems often have weird
2288internal needs.
2289
2290We've tried to make this also work with the TODO: syntax, but it's not
2291guaranteed and its use is also discouraged:
2292
2293 TODO: {
2294 local $TODO = 'We have work to do!';
2295 $Test->todo_start('working on this');
2296 # lots of code
2297 $Test->todo_start('working on that');
2298 # more code
2299 $Test->todo_end;
2300 $Test->todo_end;
2301 }
2302
2303Pick one style or another of "TODO" to be on the safe side.
2304
2305=cut
2306
2307sub todo_start {
2308 my $self = shift;
2309 my $message = @_ ? shift : '';
2310
2311 $self->{Start_Todo}++;
2312 if( $self->in_todo ) {
2313 push @{ $self->{Todo_Stack} } => $self->todo;
2314 }
2315 $self->{Todo} = $message;
2316
2317 return;
2318}
2319
2320=item C<todo_end>
2321
2322 $Test->todo_end;
2323
2324Stops running tests as "TODO" tests. This method is fatal if called without a
2325preceding C<todo_start> method call.
2326
2327=cut
2328
2329sub todo_end {
2330 my $self = shift;
2331
2332 if( !$self->{Start_Todo} ) {
2333 $self->croak('todo_end() called without todo_start()');
2334 }
2335
2336 $self->{Start_Todo}--;
2337
2338 if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
2339 $self->{Todo} = pop @{ $self->{Todo_Stack} };
2340 }
2341 else {
2342 delete $self->{Todo};
2343 }
2344
2345 return;
2346}
2347
2348=item B<caller>
2349
2350 my $package = $Test->caller;
2351 my($pack, $file, $line) = $Test->caller;
2352 my($pack, $file, $line) = $Test->caller($height);
2353
2354Like the normal C<caller()>, except it reports according to your C<level()>.
2355
2356C<$height> will be added to the C<level()>.
2357
2358If C<caller()> winds up off the top of the stack it report the highest context.
2359
2360=cut
2361
2362
# spent 228µs (200+27) within Test::Builder::caller which was called 17 times, avg 13µs/call: # 15 times (173µs+24µs) by Test::Builder::find_TODO at line 2240, avg 13µs/call # 2 times (28µs+3µs) by Test::Builder::cmp_ok at line 1169, avg 15µs/call
sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
2363177µs my( $self, $height ) = @_;
2364173µs $height ||= 0;
2365
23661727µs1727µs my $level = $self->level + $height + 1;
# spent 27µs making 17 calls to Test::Builder::level, avg 2µs/call
2367176µs my @caller;
23681715µs do {
23691777µs @caller = CORE::caller( $level );
2370176µs $level--;
2371 } until @caller;
23721757µs return wantarray ? @caller : $caller[0];
2373}
2374
2375=back
2376
2377=cut
2378
2379=begin _private
2380
2381=over 4
2382
2383=item B<_sanity_check>
2384
2385 $self->_sanity_check();
2386
2387Runs a bunch of end of test sanity checks to make sure reality came
2388through ok. If anything is wrong it will die with a fairly friendly
2389error message.
2390
2391=cut
2392
2393#'#
2394sub _sanity_check {
2395 my $self = shift;
2396
2397 $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
2398 $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
2399 'Somehow you got a different number of results than tests ran!' );
2400
2401 return;
2402}
2403
2404=item B<_whoa>
2405
2406 $self->_whoa($check, $description);
2407
2408A sanity check, similar to C<assert()>. If the C<$check> is true, something
2409has gone horribly wrong. It will die with the given C<$description> and
2410a note to contact the author.
2411
2412=cut
2413
2414sub _whoa {
2415 my( $self, $check, $desc ) = @_;
2416 if($check) {
2417 local $Level = $Level + 1;
2418 $self->croak(<<"WHOA");
2419WHOA! $desc
2420This should never happen! Please contact the author immediately!
2421WHOA
2422 }
2423
2424 return;
2425}
2426
2427=item B<_my_exit>
2428
2429 _my_exit($exit_num);
2430
2431Perl seems to have some trouble with exiting inside an C<END> block.
24325.6.1 does some odd things. Instead, this function edits C<$?>
2433directly. It should B<only> be called from inside an C<END> block.
2434It doesn't actually exit, that's your job.
2435
2436=cut
2437
2438
# spent 3µs within Test::Builder::_my_exit which was called: # once (3µs+0s) by Test::Builder::_ending at line 2561
sub _my_exit {
24391900ns $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
2440
244115µs return 1;
2442}
2443
2444=back
2445
2446=end _private
2447
2448=cut
2449
2450
# spent 50µs (42+9) within Test::Builder::_ending which was called: # once (42µs+9µs) by Test::Builder::END at line 2584
sub _ending {
24511600ns my $self = shift;
245213µs14µs return if $self->no_ending;
# spent 4µs making 1 call to Test::Builder::__ANON__[Test/Builder.pm:1660]
24531800ns return if $self->{Ending}++;
2454
245511µs my $real_exit_code = $?;
2456
2457 # Don't bother with an ending if this is a forked copy. Only the parent
2458 # should do the ending.
245912µs if( $self->{Original_Pid} != $$ ) {
2460 return;
2461 }
2462
2463 # Ran tests but never declared a plan or hit done_testing
24641700ns if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
2465 $self->is_passing(0);
2466 $self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
2467
2468 if($real_exit_code) {
2469 $self->diag(<<"FAIL");
2470Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
2471FAIL
2472 $self->is_passing(0);
2473 _my_exit($real_exit_code) && return;
2474 }
2475
2476 # But if the tests ran, handle exit code.
2477 my $test_results = $self->{Test_Results};
2478 if(@$test_results) {
2479 my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
2480 if ($num_failed > 0) {
2481
2482 my $exit_code = $num_failed <= 254 ? $num_failed : 254;
2483 _my_exit($exit_code) && return;
2484 }
2485 }
2486 _my_exit(254) && return;
2487 }
2488
2489 # Exit if plan() was never called. This is so "require Test::Simple"
2490 # doesn't puke.
24911500ns if( !$self->{Have_Plan} ) {
2492 return;
2493 }
2494
2495 # Don't do an ending if we bailed out.
24961600ns if( $self->{Bailed_Out} ) {
2497 $self->is_passing(0);
2498 return;
2499 }
2500 # Figure out if we passed or failed and print helpful messages.
25011800ns my $test_results = $self->{Test_Results};
25021800ns if(@$test_results) {
2503 # The plan? We have no plan.
25041400ns if( $self->{No_Plan} ) {
2505 $self->_output_plan($self->{Curr_Test}) unless $self->no_header;
2506 $self->{Expected_Tests} = $self->{Curr_Test};
2507 }
2508
2509 # Auto-extended arrays and elements which aren't explicitly
2510 # filled in with a shared reference will puke under 5.8.0
2511 # ithreads. So we have to fill them in by hand. :(
251212µs11µs my $empty_result = &share( {} );
# spent 1µs making 1 call to Test::Builder::__ANON__[Test/Builder.pm:66]
251313µs for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
251452µs $test_results->[$idx] = $empty_result
2515 unless defined $test_results->[$idx];
2516 }
2517
251816µs my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
2519
252012µs my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
2521
25221600ns if( $num_extra != 0 ) {
2523 my $s = $self->{Expected_Tests} == 1 ? '' : 's';
2524 $self->diag(<<"FAIL");
2525Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}.
2526FAIL
2527 $self->is_passing(0);
2528 }
2529
25301500ns if($num_failed) {
2531 my $num_tests = $self->{Curr_Test};
2532 my $s = $num_failed == 1 ? '' : 's';
2533
2534 my $qualifier = $num_extra == 0 ? '' : ' run';
2535
2536 $self->diag(<<"FAIL");
2537Looks like you failed $num_failed test$s of $num_tests$qualifier.
2538FAIL
2539 $self->is_passing(0);
2540 }
2541
25421300ns if($real_exit_code) {
2543 $self->diag(<<"FAIL");
2544Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
2545FAIL
2546 $self->is_passing(0);
2547 _my_exit($real_exit_code) && return;
2548 }
2549
25501400ns my $exit_code;
25511900ns if($num_failed) {
2552 $exit_code = $num_failed <= 254 ? $num_failed : 254;
2553 }
2554 elsif( $num_extra != 0 ) {
2555 $exit_code = 255;
2556 }
2557 else {
25581400ns $exit_code = 0;
2559 }
2560
256117µs13µs _my_exit($exit_code) && return;
# spent 3µs making 1 call to Test::Builder::_my_exit
2562 }
2563 elsif( $self->{Skip_All} ) {
2564 _my_exit(0) && return;
2565 }
2566 elsif($real_exit_code) {
2567 $self->diag(<<"FAIL");
2568Looks like your test exited with $real_exit_code before it could output anything.
2569FAIL
2570 $self->is_passing(0);
2571 _my_exit($real_exit_code) && return;
2572 }
2573 else {
2574 $self->diag("No tests run!\n");
2575 $self->is_passing(0);
2576 _my_exit(255) && return;
2577 }
2578
2579 $self->is_passing(0);
2580 $self->_whoa( 1, "We fell off the end of _ending()" );
2581}
2582
2583
# spent 57µs (6+50) within Test::Builder::END which was called: # once (6µs+50µs) by main::RUNTIME at line 0 of t/optimization.t
END {
258416µs150µs $Test->_ending if defined $Test;
# spent 50µs making 1 call to Test::Builder::_ending
2585}
2586
2587=head1 EXIT CODES
2588
2589If all your tests passed, Test::Builder will exit with zero (which is
2590normal). If anything failed it will exit with how many failed. If
2591you run less (or more) tests than you planned, the missing (or extras)
2592will be considered failures. If no tests were ever run Test::Builder
2593will throw a warning and exit with 255. If the test died, even after
2594having successfully completed all its tests, it will still be
2595considered a failure and will exit with 255.
2596
2597So the exit codes are...
2598
2599 0 all tests successful
2600 255 test died or all passed but wrong # of tests run
2601 any other number how many failed (including missing or extras)
2602
2603If you fail more than 254 tests, it will be reported as 254.
2604
2605=head1 THREADS
2606
2607In perl 5.8.1 and later, Test::Builder is thread-safe. The test
2608number is shared amongst all threads. This means if one thread sets
2609the test number using C<current_test()> they will all be effected.
2610
2611While versions earlier than 5.8.1 had threads they contain too many
2612bugs to support.
2613
2614Test::Builder is only thread-aware if threads.pm is loaded I<before>
2615Test::Builder.
2616
2617=head1 MEMORY
2618
2619An informative hash, accessible via C<<details()>>, is stored for each
2620test you perform. So memory usage will scale linearly with each test
2621run. Although this is not a problem for most test suites, it can
2622become an issue if you do large (hundred thousands to million)
2623combinatorics tests in the same run.
2624
2625In such cases, you are advised to either split the test file into smaller
2626ones, or use a reverse approach, doing "normal" (code) compares and
2627triggering fail() should anything go unexpected.
2628
2629Future versions of Test::Builder will have a way to turn history off.
2630
2631
2632=head1 EXAMPLES
2633
2634CPAN can provide the best examples. Test::Simple, Test::More,
2635Test::Exception and Test::Differences all use Test::Builder.
2636
2637=head1 SEE ALSO
2638
2639Test::Simple, Test::More, Test::Harness
2640
2641=head1 AUTHORS
2642
2643Original code by chromatic, maintained by Michael G Schwern
2644E<lt>schwern@pobox.comE<gt>
2645
2646=head1 COPYRIGHT
2647
2648Copyright 2002-2008 by chromatic E<lt>chromatic@wgz.orgE<gt> and
2649 Michael G Schwern E<lt>schwern@pobox.comE<gt>.
2650
2651This program is free software; you can redistribute it and/or
2652modify it under the same terms as Perl itself.
2653
2654See F<http://www.perl.com/perl/misc/Artistic.html>
2655
2656=cut
2657
2658116µs1;
2659
 
# spent 11µs within Test::Builder::CORE:binmode which was called 2 times, avg 6µs/call: # 2 times (11µs+0s) by Test::Builder::_apply_layers at line 1978, avg 6µs/call
sub Test::Builder::CORE:binmode; # opcode
# spent 41µs within Test::Builder::CORE:match which was called 17 times, avg 2µs/call: # 6 times (9µs+0s) by Test::Builder::_print_to_fh at line 1819, avg 2µs/call # 5 times (23µs+0s) by Test::Builder::ok at line 824, avg 5µs/call # 5 times (5µs+0s) by Test::Builder::_check_is_passing_plan at line 905, avg 980ns/call # once (4µs+0s) by Test::Builder::expected_tests at line 579
sub Test::Builder::CORE:match; # opcode
# spent 33µs within Test::Builder::CORE:open which was called 2 times, avg 16µs/call: # once (28µs+0s) by Test::Builder::_open_testhandles at line 1948 # once (5µs+0s) by Test::Builder::_open_testhandles at line 1949
sub Test::Builder::CORE:open; # opcode
# spent 132µs within Test::Builder::CORE:print which was called 6 times, avg 22µs/call: # 6 times (132µs+0s) by Test::Builder::_print_to_fh at line 1821, avg 22µs/call
sub Test::Builder::CORE:print; # opcode
# spent 5µs within Test::Builder::CORE:select which was called 8 times, avg 638ns/call: # 4 times (3µs+0s) by Test::Builder::_autoflush at line 1915, avg 825ns/call # 4 times (2µs+0s) by Test::Builder::_autoflush at line 1917, avg 450ns/call
sub Test::Builder::CORE:select; # opcode
# spent 24µs within Test::Builder::CORE:subst which was called 11 times, avg 2µs/call: # 6 times (17µs+0s) by Test::Builder::_print_to_fh at line 1816, avg 3µs/call # 5 times (7µs+0s) by Test::Builder::ok at line 852, avg 1µs/call
sub Test::Builder::CORE:subst; # opcode