← Index
NYTProf Performance Profile   « block view • line view • sub view »
For 01.HTTP.t
  Run on Tue May 4 15:25:55 2010
Reported on Tue May 4 15:26:21 2010

File /usr/local/lib/perl5/5.10.1/Test/Builder.pm
Statements Executed 1020
Statement Execution Time 21.5ms
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
111683µs783µsTest::Builder::::BEGIN@19Test::Builder::BEGIN@19
431329µs1.67msTest::Builder::::okTest::Builder::ok
1732292µs342µsTest::Builder::::_tryTest::Builder::_try
1211175µs203µsTest::Builder::::callerTest::Builder::caller
511150µs293µsTest::Builder::::_print_to_fhTest::Builder::_print_to_fh
811148µs498µsTest::Builder::::_unoverloadTest::Builder::_unoverload
51293µs93µsTest::Builder::::CORE:printTest::Builder::CORE:print (opcode)
122187µs290µsTest::Builder::::find_TODOTest::Builder::find_TODO
22281µs81µsTest::Builder::::CORE:openTest::Builder::CORE:open (opcode)
81166µs184µsTest::Builder::::_is_objectTest::Builder::_is_object
11160µs75µsTest::Builder::::_endingTest::Builder::_ending
11153µs353µsTest::Builder::::resetTest::Builder::reset
52153µs367µsTest::Builder::::_printTest::Builder::_print
41149µs68µsTest::Builder::::_check_is_passing_planTest::Builder::_check_is_passing_plan
82148µs205µsTest::Builder::::in_todoTest::Builder::in_todo
44145µs58µsTest::Builder::::_autoflushTest::Builder::_autoflush
41143µs176µsTest::Builder::::todoTest::Builder::todo
82143µs541µsTest::Builder::::_unoverload_strTest::Builder::_unoverload_str
11136µs40µsTest::Builder::::BEGIN@18Test::Builder::BEGIN@18
144233µs33µsTest::Builder::::CORE:matchTest::Builder::CORE:match (opcode)
11132µs290µsTest::Builder::::_dup_stdhandlesTest::Builder::_dup_stdhandles
62132µs54µsTest::Builder::::outputTest::Builder::output
33131µs42µsTest::Builder::::_new_fhTest::Builder::_new_fh
11131µs31µsTest::Builder::::BEGIN@3Test::Builder::BEGIN@3
62230µs400µsTest::Builder::::newTest::Builder::new
121128µs28µsTest::Builder::::levelTest::Builder::level
51126µs26µsTest::Builder::::_indentTest::Builder::_indent
11125µs94µsTest::Builder::::reset_outputsTest::Builder::reset_outputs
11124µs105µsTest::Builder::::_open_testhandlesTest::Builder::_open_testhandles
92221µs21µsTest::Builder::::CORE:substTest::Builder::CORE:subst (opcode)
11120µs119µsTest::Builder::::expected_testsTest::Builder::expected_tests
81120µs20µsTest::Builder::::__ANON__[:812]Test::Builder::__ANON__[:812]
74120µs20µsTest::Builder::::__ANON__[:66]Test::Builder::__ANON__[:66]
41117µs17µsTest::Builder::::use_numbersTest::Builder::use_numbers
11117µs370µsTest::Builder::::createTest::Builder::create
41115µs15µsTest::Builder::::has_planTest::Builder::has_plan
81114µs14µsTest::Builder::::__ANON__[:828]Test::Builder::__ANON__[:828]
11114µs14µsTest::Builder::::BEGIN@10Test::Builder::BEGIN@10
82213µs13µsTest::Builder::::CORE:selectTest::Builder::CORE:select (opcode)
11113µs88µsTest::Builder::::ENDTest::Builder::END
22111µs11µsTest::Builder::::__ANON__[:1538]Test::Builder::__ANON__[:1538]
11111µs85µsTest::Builder::::_output_planTest::Builder::_output_plan
31111µs11µsTest::Builder::::is_fhTest::Builder::is_fh
11110µs24µsTest::Builder::::BEGIN@857Test::Builder::BEGIN@857
41110µs10µsTest::Builder::::__ANON__[:67]Test::Builder::__ANON__[:67]
11110µs129µsTest::Builder::::_plan_testsTest::Builder::_plan_tests
11110µs22µsTest::Builder::::BEGIN@1161Test::Builder::BEGIN@1161
11110µs139µsTest::Builder::::planTest::Builder::plan
1119µs19µsTest::Builder::::failure_outputTest::Builder::failure_output
1118µs18µsTest::Builder::::todo_outputTest::Builder::todo_output
1118µs20µsTest::Builder::::BEGIN@5Test::Builder::BEGIN@5
1118µs11µsTest::Builder::::BEGIN@4Test::Builder::BEGIN@4
1117µs19µsTest::Builder::::BEGIN@2107Test::Builder::BEGIN@2107
1117µs21µsTest::Builder::::BEGIN@1540Test::Builder::BEGIN@1540
1115µs5µsTest::Builder::::exported_toTest::Builder::exported_to
1114µs4µsTest::Builder::::is_passingTest::Builder::is_passing
1114µs4µsTest::Builder::::_my_exitTest::Builder::_my_exit
0000s0sTest::Builder::::BAIL_OUTTest::Builder::BAIL_OUT
0000s0sTest::Builder::::DESTROYTest::Builder::DESTROY
0000s0sTest::Builder::::__ANON__[:1652]Test::Builder::__ANON__[:1652]
0000s0sTest::Builder::::__ANON__[:1845]Test::Builder::__ANON__[:1845]
0000s0sTest::Builder::::__ANON__[:61]Test::Builder::__ANON__[:61]
0000s0sTest::Builder::::_caller_contextTest::Builder::_caller_context
0000s0sTest::Builder::::_cmp_diagTest::Builder::_cmp_diag
0000s0sTest::Builder::::_copy_io_layersTest::Builder::_copy_io_layers
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::::_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::::cmp_okTest::Builder::cmp_ok
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_eqTest::Builder::is_eq
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
3347µs131µs
# spent 31µs within Test::Builder::BEGIN@3 which was called # once (31µs+0s) by Test::Builder::Module::BEGIN@5 at line 3
use 5.006;
# spent 31µs making 1 call to Test::Builder::BEGIN@3
4325µs215µs
# spent 11µs (8+3) within Test::Builder::BEGIN@4 which was called # once (8µs+3µs) by Test::Builder::Module::BEGIN@5 at line 4
use strict;
# spent 11µs making 1 call to Test::Builder::BEGIN@4 # spent 3µs making 1 call to strict::import
5373µs232µs
# spent 20µs (8+12) within Test::Builder::BEGIN@5 which was called # once (8µs+12µs) by Test::Builder::Module::BEGIN@5 at line 5
use warnings;
# spent 20µs making 1 call to Test::Builder::BEGIN@5 # spent 12µs making 1 call to warnings::import
6
713µsour $VERSION = '0.94';
8140µs$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
9
10
# spent 14µs within Test::Builder::BEGIN@10 which was called # once (14µs+0s) by Test::Builder::Module::BEGIN@5 at line 14
BEGIN {
11115µs if( $] < 5.008 ) {
12 require Test::Builder::IO::Scalar;
13 }
14128µs114µs}
# spent 14µs making 1 call to Test::Builder::BEGIN@10
15
16
17# Make Test::Builder thread-safe for ithreads.
18
# spent 40µs (36+4) within Test::Builder::BEGIN@18 which was called # once (36µs+4µs) by Test::Builder::Module::BEGIN@5 at line 69
BEGIN {
193388µs2799µs
# spent 783µs (683+100) within Test::Builder::BEGIN@19 which was called # once (683µs+100µs) by Test::Builder::Module::BEGIN@5 at line 19
use Config;
# spent 783µs 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.
22124µs14µs if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
# spent 4µs making 1 call to Config::FETCH
23 require threads::shared;
24
25 # Hack around YET ANOTHER threads::shared bug. It would
26 # occassionally 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 {
66837µs
# spent 20µs within Test::Builder::__ANON__[/usr/local/lib/perl5/5.10.1/Test/Builder.pm:66] which was called 7 times, avg 3µs/call: # 4 times (11µs+0s) by Test::Builder::ok at line 736, avg 3µs/call # once (4µs+0s) by Test::Builder::reset at line 358 # once (4µs+0s) by Test::Builder::_ending at line 2354 # once (2µs+0s) by Test::Builder::reset at line 360
*share = sub { return $_[0] };
67524µs
# spent 10µs within Test::Builder::__ANON__[/usr/local/lib/perl5/5.10.1/Test/Builder.pm:67] which was called 4 times, avg 3µs/call: # 4 times (10µs+0s) by Test::Builder::ok at line 716, avg 3µs/call
*lock = sub { 0 };
68 }
6912.21ms140µs}
# spent 40µ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 the 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
11919µs1381µsour $Test = Test::Builder->new;
# spent 381µs making 1 call to Test::Builder::new
120
121
# spent 400µs (30+370) within Test::Builder::new which was called 6 times, avg 67µs/call: # 5 times (19µs+0s) by Test::Builder::Module::builder at line 170 of Test/Builder/Module.pm, avg 4µs/call # once (12µs+370µs) by Test::Builder::Module::BEGIN@5 at line 119
sub new {
12266µs my($class) = shift;
12366µs1370µs $Test ||= $class->create;
# spent 370µs making 1 call to Test::Builder::create
124631µ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 370µs (17+353) within Test::Builder::create which was called # once (17µs+353µs) by Test::Builder::new at line 123
sub create {
1421700ns my $class = shift;
143
14419µs my $self = bless {}, $class;
14512µs1353µs $self->reset;
# spent 353µs making 1 call to Test::Builder::reset
146
14714µs return $self;
148}
149
150=item B<child>
151
152 my $child = $builder->child($name_of_child);
153 $child->plan( tests => 4 );
154 $child->ok(some_code());
155 ...
156 $child->finalize;
157
158Returns a new instance of C<Test::Builder>. Any output from this child will
159indented four spaces more than the parent's indentation. When done, the
160C<finalize> method I<must> be called explicitly.
161
162Trying to create a new child with a previous child still active (i.e.,
163C<finalize> not called) will C<croak>.
164
165Trying to run a test when you have an open child will also C<croak> and cause
166the test suite to fail.
167
168=cut
169
170sub child {
171 my( $self, $name ) = @_;
172
173 if( $self->{Child_Name} ) {
174 $self->croak("You already have a child named ($self->{Child_Name}) running");
175 }
176
177 my $child = bless {}, ref $self;
178 $child->reset;
179
180 # Add to our indentation
181 $child->_indent( $self->_indent . ' ' );
182 $child->{$_} = $self->{$_} foreach qw{Out_FH Todo_FH Fail_FH};
183
184 # This will be reset in finalize. We do this here lest one child failure
185 # cause all children to fail.
186 $child->{Child_Error} = $?;
187 $? = 0;
188 $child->{Parent} = $self;
189 $child->{Name} = $name || "Child of " . $self->name;
190 $self->{Child_Name} = $child->name;
191 return $child;
192}
193
194
195=item B<subtest>
196
197 $builder->subtest($name, \&subtests);
198
199See documentation of C<subtest> in Test::More.
200
201=cut
202
203sub subtest {
204 my $self = shift;
205 my($name, $subtests) = @_;
206
207 if ('CODE' ne ref $subtests) {
208 $self->croak("subtest()'s second argument must be a code ref");
209 }
210
211 # Turn the child into the parent so anyone who has stored a copy of
212 # the Test::Builder singleton will get the child.
213 my $child = $self->child($name);
214 my %parent = %$self;
215 %$self = %$child;
216
217 my $error;
218 if( !eval { $subtests->(); 1 } ) {
219 $error = $@;
220 }
221
222 # Restore the parent and the copied child.
223 %$child = %$self;
224 %$self = %parent;
225
226 # Die *after* we restore the parent.
227 die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
228
229 return $child->finalize;
230}
231
232
233=item B<finalize>
234
235 my $ok = $child->finalize;
236
237When your child is done running tests, you must call C<finalize> to clean up
238and tell the parent your pass/fail status.
239
240Calling finalize on a child with open children will C<croak>.
241
242If the child falls out of scope before C<finalize> is called, a failure
243diagnostic will be issued and the child is considered to have failed.
244
245No attempt to call methods on a child after C<finalize> is called is
246guaranteed to succeed.
247
248Calling this on the root builder is a no-op.
249
250=cut
251
252sub finalize {
253 my $self = shift;
254
255 return unless $self->parent;
256 if( $self->{Child_Name} ) {
257 $self->croak("Can't call finalize() with child ($self->{Child_Name}) active");
258 }
259 $self->_ending;
260
261 # XXX This will only be necessary for TAP envelopes (we think)
262 #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );
263
264 my $ok = 1;
265 $self->parent->{Child_Name} = undef;
266 if ( $self->{Skip_All} ) {
267 $self->parent->skip($self->{Skip_All});
268 }
269 elsif ( not @{ $self->{Test_Results} } ) {
270 $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name );
271 }
272 else {
273 $self->parent->ok( $self->is_passing, $self->name );
274 }
275 $? = $self->{Child_Error};
276 delete $self->{Parent};
277
278 return $self->is_passing;
279}
280
281
# spent 26µs within Test::Builder::_indent which was called 5 times, avg 5µs/call: # 5 times (26µs+0s) by Test::Builder::_print_to_fh at line 1698, avg 5µs/call
sub _indent {
28253µs my $self = shift;
283
28453µs if( @_ ) {
285 $self->{Indent} = shift;
286 }
287
288522µs return $self->{Indent};
289}
290
291=item B<parent>
292
293 if ( my $parent = $builder->parent ) {
294 ...
295 }
296
297Returns the parent C<Test::Builder> instance, if any. Only used with child
298builders for nested TAP.
299
300=cut
301
302sub parent { shift->{Parent} }
303
304=item B<name>
305
306 diag $builder->name;
307
308Returns the name of the current builder. Top level builders default to C<$0>
309(the name of the executable). Child builders are named via the C<child>
310method. If no name is supplied, will be named "Child of $parent->name".
311
312=cut
313
314sub name { shift->{Name} }
315
316sub DESTROY {
317 my $self = shift;
318 if ( $self->parent ) {
319 my $name = $self->name;
320 $self->diag(<<"FAIL");
321Child ($name) exited without calling finalize()
322FAIL
323 $self->parent->{In_Destroy} = 1;
324 $self->parent->ok(0, $name);
325 }
326}
327
328=item B<reset>
329
330 $Test->reset;
331
332Reinitializes the Test::Builder singleton to its original state.
333Mostly useful for tests run in persistent environments where the same
334test might be run multiple times in the same process.
335
336=cut
337
3381200nsour $Level;
339
340
# spent 353µs (53+300) within Test::Builder::reset which was called # once (53µs+300µs) by Test::Builder::create at line 145
sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
3411800ns my($self) = @_;
342
343 # We leave this a global because it has to be localized and localizing
344 # hash keys is just asking for pain. Also, it was documented.
3451500ns $Level = 1;
346
34713µs $self->{Name} = $0;
34812µs14µs $self->is_passing(1);
# spent 4µs making 1 call to Test::Builder::is_passing
3491900ns $self->{Ending} = 0;
3501600ns $self->{Have_Plan} = 0;
3511400ns $self->{No_Plan} = 0;
3521400ns $self->{Have_Output_Plan} = 0;
353
3541400ns $self->{Original_Pid} = $$;
35512µs $self->{Child_Name} = undef;
35611µs $self->{Indent} ||= '';
357
35814µs14µs share( $self->{Curr_Test} );
# spent 4µs making 1 call to Test::Builder::__ANON__[Test/Builder.pm:66]
3591700ns $self->{Curr_Test} = 0;
36013µs12µs $self->{Test_Results} = &share( [] );
# spent 2µs making 1 call to Test::Builder::__ANON__[Test/Builder.pm:66]
361
3621400ns $self->{Exported_To} = undef;
3631400ns $self->{Expected_Tests} = 0;
364
3651400ns $self->{Skip_All} = 0;
366
3671400ns $self->{Use_Nums} = 1;
368
36912µs $self->{No_Header} = 0;
3701400ns $self->{No_Ending} = 0;
371
3721400ns $self->{Todo} = undef;
3731800ns $self->{Todo_Stack} = [];
3741400ns $self->{Start_Todo} = 0;
3751400ns $self->{Opened_Testhandles} = 0;
376
37712µs1290µs $self->_dup_stdhandles;
# spent 290µs making 1 call to Test::Builder::_dup_stdhandles
378
37914µs return;
380}
381
382=back
383
384=head2 Setting up tests
385
386These methods are for setting up tests and declaring how many there
387are. You usually only want to call one of these methods.
388
389=over 4
390
391=item B<plan>
392
393 $Test->plan('no_plan');
394 $Test->plan( skip_all => $reason );
395 $Test->plan( tests => $num_tests );
396
397A convenient way to set up your tests. Call this and Test::Builder
398will print the appropriate headers and take the appropriate actions.
399
400If you call C<plan()>, don't call any of the other methods below.
401
402If a child calls "skip_all" in the plan, a C<Test::Builder::Exception> is
403thrown. Trap this error, call C<finalize()> and don't run any more tests on
404the child.
405
406 my $child = $Test->child('some child');
407 eval { $child->plan( $condition ? ( skip_all => $reason ) : ( tests => 3 ) ) };
408 if ( eval { $@->isa('Test::Builder::Exception') } ) {
409 $child->finalize;
410 return;
411 }
412 # run your tests
413
414=cut
415
41614µsmy %plan_cmds = (
417 no_plan => \&no_plan,
418 skip_all => \&skip_all,
419 tests => \&_plan_tests,
420);
421
422
# spent 139µs (10+129) within Test::Builder::plan which was called # once (10µs+129µs) by Test::Builder::Module::import at line 91 of Test/Builder/Module.pm
sub plan {
4231900ns my( $self, $cmd, $arg ) = @_;
424
4251200ns return unless $cmd;
426
4271800ns local $Level = $Level + 1;
428
4291600ns $self->croak("You tried to plan twice") if $self->{Have_Plan};
430
43111µs if( my $method = $plan_cmds{$cmd} ) {
4321300ns local $Level = $Level + 1;
43312µs1129µs $self->$method($arg);
# spent 129µs making 1 call to Test::Builder::_plan_tests
434 }
435 else {
436 my @args = grep { defined } ( $cmd, $arg );
437 $self->croak("plan() doesn't understand @args");
438 }
439
44013µs return 1;
441}
442
443
444
# spent 129µs (10+119) within Test::Builder::_plan_tests which was called # once (10µs+119µs) by Test::Builder::plan at line 433
sub _plan_tests {
4451900ns my($self, $arg) = @_;
446
4471300ns if($arg) {
4481400ns local $Level = $Level + 1;
44915µs1119µs return $self->expected_tests($arg);
# spent 119µs making 1 call to Test::Builder::expected_tests
450 }
451 elsif( !defined $arg ) {
452 $self->croak("Got an undefined number of tests");
453 }
454 else {
455 $self->croak("You said to run 0 tests");
456 }
457
458 return;
459}
460
461
462=item B<expected_tests>
463
464 my $max = $Test->expected_tests;
465 $Test->expected_tests($max);
466
467Gets/sets the number of tests we expect this test to run and prints out
468the appropriate headers.
469
470=cut
471
472
# spent 119µs (20+99) within Test::Builder::expected_tests which was called # once (20µs+99µs) by Test::Builder::_plan_tests at line 449
sub expected_tests {
4731500ns my $self = shift;
4741600ns my($max) = @_;
475
4761700ns if(@_) {
477115µs19µs $self->croak("Number of tests must be a positive integer. You gave it '$max'")
# spent 9µs making 1 call to Test::Builder::CORE:match
478 unless $max =~ /^\+?\d+$/;
479
48011µs $self->{Expected_Tests} = $max;
4811600ns $self->{Have_Plan} = 1;
482
48314µs289µs $self->_output_plan($max) unless $self->no_header;
# spent 85µs making 1 call to Test::Builder::_output_plan # spent 4µs making 1 call to Test::Builder::__ANON__[Test/Builder.pm:1538]
484 }
48516µs return $self->{Expected_Tests};
486}
487
488=item B<no_plan>
489
490 $Test->no_plan;
491
492Declares that this test will run an indeterminate number of tests.
493
494=cut
495
496sub no_plan {
497 my($self, $arg) = @_;
498
499 $self->carp("no_plan takes no arguments") if $arg;
500
501 $self->{No_Plan} = 1;
502 $self->{Have_Plan} = 1;
503
504 return 1;
505}
506
507
508=begin private
509
510=item B<_output_plan>
511
512 $tb->_output_plan($max);
513 $tb->_output_plan($max, $directive);
514 $tb->_output_plan($max, $directive => $reason);
515
516Handles displaying the test plan.
517
518If a C<$directive> and/or C<$reason> are given they will be output with the
519plan. So here's what skipping all tests looks like:
520
521 $tb->_output_plan(0, "SKIP", "Because I said so");
522
523It sets C<< $tb->{Have_Output_Plan} >> and will croak if the plan was already
524output.
525
526=end private
527
528=cut
529
530
# spent 85µs (11+75) within Test::Builder::_output_plan which was called # once (11µs+75µs) by Test::Builder::expected_tests at line 483
sub _output_plan {
53111µs my($self, $max, $directive, $reason) = @_;
532
5331400ns $self->carp("The plan was already output") if $self->{Have_Output_Plan};
534
53511µs my $plan = "1..$max";
5361300ns $plan .= " # $directive" if defined $directive;
5371200ns $plan .= " $reason" if defined $reason;
538
53913µs174µs $self->_print("$plan\n");
# spent 74µs making 1 call to Test::Builder::_print
540
5411700ns $self->{Have_Output_Plan} = 1;
542
54313µs return;
544}
545
546=item B<done_testing>
547
548 $Test->done_testing();
549 $Test->done_testing($num_tests);
550
551Declares that you are done testing, no more tests will be run after this point.
552
553If a plan has not yet been output, it will do so.
554
555$num_tests is the number of tests you planned to run. If a numbered
556plan was already declared, and if this contradicts, a failing test
557will be run to reflect the planning mistake. If C<no_plan> was declared,
558this will override.
559
560If C<done_testing()> is called twice, the second call will issue a
561failing test.
562
563If C<$num_tests> is omitted, the number of tests run will be used, like
564no_plan.
565
566C<done_testing()> is, in effect, used when you'd want to use C<no_plan>, but
567safer. You'd use it like so:
568
569 $Test->ok($a == $b);
570 $Test->done_testing();
571
572Or to plan a variable number of tests:
573
574 for my $test (@tests) {
575 $Test->ok($test);
576 }
577 $Test->done_testing(@tests);
578
579=cut
580
581sub done_testing {
582 my($self, $num_tests) = @_;
583
584 # If done_testing() specified the number of tests, shut off no_plan.
585 if( defined $num_tests ) {
586 $self->{No_Plan} = 0;
587 }
588 else {
589 $num_tests = $self->current_test;
590 }
591
592 if( $self->{Done_Testing} ) {
593 my($file, $line) = @{$self->{Done_Testing}}[1,2];
594 $self->ok(0, "done_testing() was already called at $file line $line");
595 return;
596 }
597
598 $self->{Done_Testing} = [caller];
599
600 if( $self->expected_tests && $num_tests != $self->expected_tests ) {
601 $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
602 "but done_testing() expects $num_tests");
603 }
604 else {
605 $self->{Expected_Tests} = $num_tests;
606 }
607
608 $self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
609
610 $self->{Have_Plan} = 1;
611
612 # The wrong number of tests were run
613 $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test};
614
615 # No tests were run
616 $self->is_passing(0) if $self->{Curr_Test} == 0;
617
618 return 1;
619}
620
621
622=item B<has_plan>
623
624 $plan = $Test->has_plan
625
626Find out whether a plan has been defined. C<$plan> is either C<undef> (no plan
627has been set), C<no_plan> (indeterminate # of tests) or an integer (the number
628of expected tests).
629
630=cut
631
632
# spent 15µs within Test::Builder::has_plan which was called 4 times, avg 4µs/call: # 4 times (15µs+0s) by Test::Builder::_check_is_passing_plan at line 801, avg 4µs/call
sub has_plan {
63342µs my $self = shift;
634
635419µs return( $self->{Expected_Tests} ) if $self->{Expected_Tests};
636 return('no_plan') if $self->{No_Plan};
637 return(undef);
638}
639
640=item B<skip_all>
641
642 $Test->skip_all;
643 $Test->skip_all($reason);
644
645Skips all the tests, using the given C<$reason>. Exits immediately with 0.
646
647=cut
648
649sub skip_all {
650 my( $self, $reason ) = @_;
651
652 $self->{Skip_All} = $self->parent ? $reason : 1;
653
654 $self->_output_plan(0, "SKIP", $reason) unless $self->no_header;
655 if ( $self->parent ) {
656 die bless {} => 'Test::Builder::Exception';
657 }
658 exit(0);
659}
660
661=item B<exported_to>
662
663 my $pack = $Test->exported_to;
664 $Test->exported_to($pack);
665
666Tells Test::Builder what package you exported your functions to.
667
668This method isn't terribly useful since modules which share the same
669Test::Builder object might get exported to different packages and only
670the last one will be honored.
671
672=cut
673
674
# 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 {
67511µs my( $self, $pack ) = @_;
676
67712µs if( defined $pack ) {
678 $self->{Exported_To} = $pack;
679 }
68014µs return $self->{Exported_To};
681}
682
683=back
684
685=head2 Running tests
686
687These actually run the tests, analogous to the functions in Test::More.
688
689They all return true if the test passed, false if the test failed.
690
691C<$name> is always optional.
692
693=over 4
694
695=item B<ok>
696
697 $Test->ok($test, $name);
698
699Your basic test. Pass if C<$test> is true, fail if $test is false. Just
700like Test::Simple's C<ok()>.
701
702=cut
703
704
# spent 1.67ms (329µs+1.34) within Test::Builder::ok which was called 4 times, avg 417µs/call: # 2 times (167µs+667µs) by Test::More::ok at line 295 of Test/More.pm, avg 417µs/call # once (75µs+356µs) by Test::More::isa_ok at line 626 of Test/More.pm # once (88µs+314µs) by Test::More::use_ok at line 834 of Test/More.pm
sub ok {
70546µs my( $self, $test, $name ) = @_;
706
70747µs if ( $self->{Child_Name} and not $self->{In_Destroy} ) {
708 $name = 'unnamed test' unless defined $name;
709 $self->is_passing(0);
710 $self->croak("Cannot run test ($name) with active children");
711 }
712 # $test might contain an object which we don't want to accidentally
713 # store, so we turn it into a boolean.
71443µs $test = $test ? 1 : 0;
715
716414µs410µs lock $self->{Curr_Test};
# spent 10µs making 4 calls to Test::Builder::__ANON__[Test/Builder.pm:67], avg 3µs/call
71742µs $self->{Curr_Test}++;
718
719 # In case $name is a string overloaded object, force it to stringify.
720413µs4332µs $self->_unoverload_str( \$name );
# spent 332µs making 4 calls to Test::Builder::_unoverload_str, avg 83µs/call
721
722432µs412µs $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
# spent 12µs making 4 calls to Test::Builder::CORE:match, avg 3µs/call
723 You named your test '$name'. You shouldn't use numbers for your test names.
724 Very confusing.
725ERR
726
727 # Capture the value of $TODO for the rest of this ok() call
728 # so it can more easily be found by other routines.
729415µs4176µs my $todo = $self->todo();
# spent 176µs making 4 calls to Test::Builder::todo, avg 44µs/call
730412µs4101µs my $in_todo = $self->in_todo;
# spent 101µs making 4 calls to Test::Builder::in_todo, avg 25µs/call
73141µs local $self->{Todo} = $todo if $in_todo;
732
73348µs4210µs $self->_unoverload_str( \$todo );
# spent 210µs making 4 calls to Test::Builder::_unoverload_str, avg 52µs/call
734
73541µs my $out;
736414µs411µs my $result = &share( {} );
# spent 11µs making 4 calls to Test::Builder::__ANON__[Test/Builder.pm:66], avg 3µs/call
737
73845µs unless($test) {
739 $out .= "not ";
740 @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
741 }
742 else {
743413µs @$result{ 'ok', 'actual_ok' } = ( 1, $test );
744 }
745
74643µs $out .= "ok";
747418µs417µs $out .= " $self->{Curr_Test}" if $self->use_numbers;
# spent 17µs making 4 calls to Test::Builder::use_numbers, avg 4µs/call
748
74943µs if( defined $name ) {
750419µs44µs $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
# spent 4µs making 4 calls to Test::Builder::CORE:subst, avg 1µs/call
75146µs $out .= " - $name";
75246µs $result->{name} = $name;
753 }
754 else {
755 $result->{name} = '';
756 }
757
758410µs4103µs if( $self->in_todo ) {
# spent 103µs making 4 calls to Test::Builder::in_todo, avg 26µs/call
759 $out .= " # TODO $todo";
760 $result->{reason} = $todo;
761 $result->{type} = 'todo';
762 }
763 else {
76447µs $result->{reason} = '';
76546µs $result->{type} = '';
766 }
767
768410µs $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
76942µs $out .= "\n";
770
771414µs4293µs $self->_print($out);
# spent 293µs making 4 calls to Test::Builder::_print, avg 73µs/call
772
77341µs unless($test) {
774 my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
775 $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
776
777 my( undef, $file, $line ) = $self->caller;
778 if( defined $name ) {
779 $self->diag(qq[ $msg test '$name'\n]);
780 $self->diag(qq[ at $file line $line.\n]);
781 }
782 else {
783 $self->diag(qq[ $msg test at $file line $line.\n]);
784 }
785 }
786
78742µs $self->is_passing(0) unless $test || $self->in_todo;
788
789 # Check that we haven't violated the plan
790413µs468µs $self->_check_is_passing_plan();
# spent 68µs making 4 calls to Test::Builder::_check_is_passing_plan, avg 17µs/call
791
792417µs return $test ? 1 : 0;
793}
794
795
796# Check that we haven't yet violated the plan and set
797# is_passing() accordingly
798
# spent 68µs (49+20) within Test::Builder::_check_is_passing_plan which was called 4 times, avg 17µs/call: # 4 times (49µs+20µs) by Test::Builder::ok at line 790, avg 17µs/call
sub _check_is_passing_plan {
79943µs my $self = shift;
800
801411µs415µs my $plan = $self->has_plan;
# spent 15µs making 4 calls to Test::Builder::has_plan, avg 4µs/call
80241µs return unless defined $plan; # no plan yet defined
803416µs45µs return unless $plan !~ /\D/; # no numeric plan
# spent 5µs making 4 calls to Test::Builder::CORE:match, avg 1µs/call
804415µs $self->is_passing(0) if $plan < $self->{Curr_Test};
805}
806
807
808
# spent 498µs (148+350) within Test::Builder::_unoverload which was called 8 times, avg 62µs/call: # 8 times (148µs+350µs) by Test::Builder::_unoverload_str at line 834, avg 62µs/call
sub _unoverload {
80983µs my $self = shift;
81084µs my $type = shift;
811
8121682µs8166µs
# spent 20µs within Test::Builder::__ANON__[/usr/local/lib/perl5/5.10.1/Test/Builder.pm:812] which was called 8 times, avg 3µs/call: # 8 times (20µs+0s) by Test::Builder::_try at line 1400, avg 3µs/call
$self->_try(sub { require overload; }, die_on_fail => 1);
# spent 166µs making 8 calls to Test::Builder::_try, avg 21µs/call
813
814816µs foreach my $thing (@_) {
815846µs8184µs if( $self->_is_object($$thing) ) {
# spent 184µs making 8 calls to Test::Builder::_is_object, avg 23µs/call
816 if( my $string_meth = overload::Method( $$thing, $type ) ) {
817 $$thing = $$thing->$string_meth();
818 }
819 }
820 }
821
822821µs return;
823}
824
825
# spent 184µs (66+119) within Test::Builder::_is_object which was called 8 times, avg 23µs/call: # 8 times (66µs+119µs) by Test::Builder::_unoverload at line 815, avg 23µs/call
sub _is_object {
82687µs my( $self, $thing ) = @_;
827
8281676µs8119µs
# spent 14µs within Test::Builder::__ANON__[/usr/local/lib/perl5/5.10.1/Test/Builder.pm:828] which was called 8 times, avg 2µs/call: # 8 times (14µs+0s) by Test::Builder::_try at line 1400, avg 2µs/call
return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
# spent 119µs making 8 calls to Test::Builder::_try, avg 15µs/call
829}
830
831
# spent 541µs (43+498) within Test::Builder::_unoverload_str which was called 8 times, avg 68µs/call: # 4 times (27µs+304µs) by Test::Builder::ok at line 720, avg 83µs/call # 4 times (15µs+194µs) by Test::Builder::ok at line 733, avg 52µs/call
sub _unoverload_str {
83283µs my $self = shift;
833
834839µs8498µs return $self->_unoverload( q[""], @_ );
# spent 498µs making 8 calls to Test::Builder::_unoverload, avg 62µs/call
835}
836
837sub _unoverload_num {
838 my $self = shift;
839
840 $self->_unoverload( '0+', @_ );
841
842 for my $val (@_) {
843 next unless $self->_is_dualvar($$val);
844 $$val = $$val + 0;
845 }
846
847 return;
848}
849
850# This is a hack to detect a dualvar such as $!
851sub _is_dualvar {
852 my( $self, $val ) = @_;
853
854 # Objects are not dualvars.
855 return 0 if ref $val;
856
8573989µs238µs
# spent 24µs (10+14) within Test::Builder::BEGIN@857 which was called # once (10µs+14µs) by Test::Builder::Module::BEGIN@5 at line 857
no warnings 'numeric';
# spent 24µs making 1 call to Test::Builder::BEGIN@857 # spent 14µs making 1 call to warnings::unimport
858 my $numval = $val + 0;
859 return $numval != 0 and $numval ne $val ? 1 : 0;
860}
861
862=item B<is_eq>
863
864 $Test->is_eq($got, $expected, $name);
865
866Like Test::More's C<is()>. Checks if C<$got eq $expected>. This is the
867string version.
868
869=item B<is_num>
870
871 $Test->is_num($got, $expected, $name);
872
873Like Test::More's C<is()>. Checks if C<$got == $expected>. This is the
874numeric version.
875
876=cut
877
878sub is_eq {
879 my( $self, $got, $expect, $name ) = @_;
880 local $Level = $Level + 1;
881
882 $self->_unoverload_str( \$got, \$expect );
883
884 if( !defined $got || !defined $expect ) {
885 # undef only matches undef and nothing else
886 my $test = !defined $got && !defined $expect;
887
888 $self->ok( $test, $name );
889 $self->_is_diag( $got, 'eq', $expect ) unless $test;
890 return $test;
891 }
892
893 return $self->cmp_ok( $got, 'eq', $expect, $name );
894}
895
896sub is_num {
897 my( $self, $got, $expect, $name ) = @_;
898 local $Level = $Level + 1;
899
900 $self->_unoverload_num( \$got, \$expect );
901
902 if( !defined $got || !defined $expect ) {
903 # undef only matches undef and nothing else
904 my $test = !defined $got && !defined $expect;
905
906 $self->ok( $test, $name );
907 $self->_is_diag( $got, '==', $expect ) unless $test;
908 return $test;
909 }
910
911 return $self->cmp_ok( $got, '==', $expect, $name );
912}
913
914sub _diag_fmt {
915 my( $self, $type, $val ) = @_;
916
917 if( defined $$val ) {
918 if( $type eq 'eq' or $type eq 'ne' ) {
919 # quote and force string context
920 $$val = "'$$val'";
921 }
922 else {
923 # force numeric context
924 $self->_unoverload_num($val);
925 }
926 }
927 else {
928 $$val = 'undef';
929 }
930
931 return;
932}
933
934sub _is_diag {
935 my( $self, $got, $type, $expect ) = @_;
936
937 $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
938
939 local $Level = $Level + 1;
940 return $self->diag(<<"DIAGNOSTIC");
941 got: $got
942 expected: $expect
943DIAGNOSTIC
944
945}
946
947sub _isnt_diag {
948 my( $self, $got, $type ) = @_;
949
950 $self->_diag_fmt( $type, \$got );
951
952 local $Level = $Level + 1;
953 return $self->diag(<<"DIAGNOSTIC");
954 got: $got
955 expected: anything else
956DIAGNOSTIC
957}
958
959=item B<isnt_eq>
960
961 $Test->isnt_eq($got, $dont_expect, $name);
962
963Like Test::More's C<isnt()>. Checks if C<$got ne $dont_expect>. This is
964the string version.
965
966=item B<isnt_num>
967
968 $Test->isnt_num($got, $dont_expect, $name);
969
970Like Test::More's C<isnt()>. Checks if C<$got ne $dont_expect>. This is
971the numeric version.
972
973=cut
974
975sub isnt_eq {
976 my( $self, $got, $dont_expect, $name ) = @_;
977 local $Level = $Level + 1;
978
979 if( !defined $got || !defined $dont_expect ) {
980 # undef only matches undef and nothing else
981 my $test = defined $got || defined $dont_expect;
982
983 $self->ok( $test, $name );
984 $self->_isnt_diag( $got, 'ne' ) unless $test;
985 return $test;
986 }
987
988 return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
989}
990
991sub isnt_num {
992 my( $self, $got, $dont_expect, $name ) = @_;
993 local $Level = $Level + 1;
994
995 if( !defined $got || !defined $dont_expect ) {
996 # undef only matches undef and nothing else
997 my $test = defined $got || defined $dont_expect;
998
999 $self->ok( $test, $name );
1000 $self->_isnt_diag( $got, '!=' ) unless $test;
1001 return $test;
1002 }
1003
1004 return $self->cmp_ok( $got, '!=', $dont_expect, $name );
1005}
1006
1007=item B<like>
1008
1009 $Test->like($this, qr/$regex/, $name);
1010 $Test->like($this, '/$regex/', $name);
1011
1012Like Test::More's C<like()>. Checks if $this matches the given C<$regex>.
1013
1014=item B<unlike>
1015
1016 $Test->unlike($this, qr/$regex/, $name);
1017 $Test->unlike($this, '/$regex/', $name);
1018
1019Like Test::More's C<unlike()>. Checks if $this B<does not match> the
1020given C<$regex>.
1021
1022=cut
1023
1024sub like {
1025 my( $self, $this, $regex, $name ) = @_;
1026
1027 local $Level = $Level + 1;
1028 return $self->_regex_ok( $this, $regex, '=~', $name );
1029}
1030
1031sub unlike {
1032 my( $self, $this, $regex, $name ) = @_;
1033
1034 local $Level = $Level + 1;
1035 return $self->_regex_ok( $this, $regex, '!~', $name );
1036}
1037
1038=item B<cmp_ok>
1039
1040 $Test->cmp_ok($this, $type, $that, $name);
1041
1042Works just like Test::More's C<cmp_ok()>.
1043
1044 $Test->cmp_ok($big_num, '!=', $other_big_num);
1045
1046=cut
1047
1048111µsmy %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
1049
1050sub cmp_ok {
1051 my( $self, $got, $type, $expect, $name ) = @_;
1052
1053 my $test;
1054 my $error;
1055 {
1056 ## no critic (BuiltinFunctions::ProhibitStringyEval)
1057
1058 local( $@, $!, $SIG{__DIE__} ); # isolate eval
1059
1060 my($pack, $file, $line) = $self->caller();
1061
1062 $test = eval qq[
1063#line 1 "cmp_ok [from $file line $line]"
1064\$got $type \$expect;
1065];
1066 $error = $@;
1067 }
1068 local $Level = $Level + 1;
1069 my $ok = $self->ok( $test, $name );
1070
1071 # Treat overloaded objects as numbers if we're asked to do a
1072 # numeric comparison.
1073 my $unoverload
1074 = $numeric_cmps{$type}
1075 ? '_unoverload_num'
1076 : '_unoverload_str';
1077
1078 $self->diag(<<"END") if $error;
1079An error occurred while using $type:
1080------------------------------------
1081$error
1082------------------------------------
1083END
1084
1085 unless($ok) {
1086 $self->$unoverload( \$got, \$expect );
1087
1088 if( $type =~ /^(eq|==)$/ ) {
1089 $self->_is_diag( $got, $type, $expect );
1090 }
1091 elsif( $type =~ /^(ne|!=)$/ ) {
1092 $self->_isnt_diag( $got, $type );
1093 }
1094 else {
1095 $self->_cmp_diag( $got, $type, $expect );
1096 }
1097 }
1098 return $ok;
1099}
1100
1101sub _cmp_diag {
1102 my( $self, $got, $type, $expect ) = @_;
1103
1104 $got = defined $got ? "'$got'" : 'undef';
1105 $expect = defined $expect ? "'$expect'" : 'undef';
1106
1107 local $Level = $Level + 1;
1108 return $self->diag(<<"DIAGNOSTIC");
1109 $got
1110 $type
1111 $expect
1112DIAGNOSTIC
1113}
1114
1115sub _caller_context {
1116 my $self = shift;
1117
1118 my( $pack, $file, $line ) = $self->caller(1);
1119
1120 my $code = '';
1121 $code .= "#line $line $file\n" if defined $file and defined $line;
1122
1123 return $code;
1124}
1125
1126=back
1127
1128
1129=head2 Other Testing Methods
1130
1131These are methods which are used in the course of writing a test but are not themselves tests.
1132
1133=over 4
1134
1135=item B<BAIL_OUT>
1136
1137 $Test->BAIL_OUT($reason);
1138
1139Indicates to the Test::Harness that things are going so badly all
1140testing should terminate. This includes running any additional test
1141scripts.
1142
1143It will exit with 255.
1144
1145=cut
1146
1147sub BAIL_OUT {
1148 my( $self, $reason ) = @_;
1149
1150 $self->{Bailed_Out} = 1;
1151 $self->_print("Bail out! $reason");
1152 exit 255;
1153}
1154
1155=for deprecated
1156BAIL_OUT() used to be BAILOUT()
1157
1158=cut
1159
1160{
11614732µs233µs
# spent 22µs (10+12) within Test::Builder::BEGIN@1161 which was called # once (10µs+12µs) by Test::Builder::Module::BEGIN@5 at line 1161
no warnings 'once';
# spent 22µs making 1 call to Test::Builder::BEGIN@1161 # spent 12µs making 1 call to warnings::unimport
116212µs *BAILOUT = \&BAIL_OUT;
1163}
1164
1165=item B<skip>
1166
1167 $Test->skip;
1168 $Test->skip($why);
1169
1170Skips the current test, reporting C<$why>.
1171
1172=cut
1173
1174sub skip {
1175 my( $self, $why ) = @_;
1176 $why ||= '';
1177 $self->_unoverload_str( \$why );
1178
1179 lock( $self->{Curr_Test} );
1180 $self->{Curr_Test}++;
1181
1182 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
1183 {
1184 'ok' => 1,
1185 actual_ok => 1,
1186 name => '',
1187 type => 'skip',
1188 reason => $why,
1189 }
1190 );
1191
1192 my $out = "ok";
1193 $out .= " $self->{Curr_Test}" if $self->use_numbers;
1194 $out .= " # skip";
1195 $out .= " $why" if length $why;
1196 $out .= "\n";
1197
1198 $self->_print($out);
1199
1200 return 1;
1201}
1202
1203=item B<todo_skip>
1204
1205 $Test->todo_skip;
1206 $Test->todo_skip($why);
1207
1208Like C<skip()>, only it will declare the test as failing and TODO. Similar
1209to
1210
1211 print "not ok $tnum # TODO $why\n";
1212
1213=cut
1214
1215sub todo_skip {
1216 my( $self, $why ) = @_;
1217 $why ||= '';
1218
1219 lock( $self->{Curr_Test} );
1220 $self->{Curr_Test}++;
1221
1222 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
1223 {
1224 'ok' => 1,
1225 actual_ok => 0,
1226 name => '',
1227 type => 'todo_skip',
1228 reason => $why,
1229 }
1230 );
1231
1232 my $out = "not ok";
1233 $out .= " $self->{Curr_Test}" if $self->use_numbers;
1234 $out .= " # TODO & SKIP $why\n";
1235
1236 $self->_print($out);
1237
1238 return 1;
1239}
1240
1241=begin _unimplemented
1242
1243=item B<skip_rest>
1244
1245 $Test->skip_rest;
1246 $Test->skip_rest($reason);
1247
1248Like C<skip()>, only it skips all the rest of the tests you plan to run
1249and terminates the test.
1250
1251If you're running under C<no_plan>, it skips once and terminates the
1252test.
1253
1254=end _unimplemented
1255
1256=back
1257
1258
1259=head2 Test building utility methods
1260
1261These methods are useful when writing your own test methods.
1262
1263=over 4
1264
1265=item B<maybe_regex>
1266
1267 $Test->maybe_regex(qr/$regex/);
1268 $Test->maybe_regex('/$regex/');
1269
1270This method used to be useful back when Test::Builder worked on Perls
1271before 5.6 which didn't have qr//. Now its pretty useless.
1272
1273Convenience method for building testing functions that take regular
1274expressions as arguments.
1275
1276Takes a quoted regular expression produced by C<qr//>, or a string
1277representing a regular expression.
1278
1279Returns a Perl value which may be used instead of the corresponding
1280regular expression, or C<undef> if its argument is not recognised.
1281
1282For example, a version of C<like()>, sans the useful diagnostic messages,
1283could be written as:
1284
1285 sub laconic_like {
1286 my ($self, $this, $regex, $name) = @_;
1287 my $usable_regex = $self->maybe_regex($regex);
1288 die "expecting regex, found '$regex'\n"
1289 unless $usable_regex;
1290 $self->ok($this =~ m/$usable_regex/, $name);
1291 }
1292
1293=cut
1294
1295sub maybe_regex {
1296 my( $self, $regex ) = @_;
1297 my $usable_regex = undef;
1298
1299 return $usable_regex unless defined $regex;
1300
1301 my( $re, $opts );
1302
1303 # Check for qr/foo/
1304 if( _is_qr($regex) ) {
1305 $usable_regex = $regex;
1306 }
1307 # Check for '/foo/' or 'm,foo,'
1308 elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
1309 ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
1310 )
1311 {
1312 $usable_regex = length $opts ? "(?$opts)$re" : $re;
1313 }
1314
1315 return $usable_regex;
1316}
1317
1318sub _is_qr {
1319 my $regex = shift;
1320
1321 # is_regexp() checks for regexes in a robust manner, say if they're
1322 # blessed.
1323 return re::is_regexp($regex) if defined &re::is_regexp;
1324 return ref $regex eq 'Regexp';
1325}
1326
1327sub _regex_ok {
1328 my( $self, $this, $regex, $cmp, $name ) = @_;
1329
1330 my $ok = 0;
1331 my $usable_regex = $self->maybe_regex($regex);
1332 unless( defined $usable_regex ) {
1333 local $Level = $Level + 1;
1334 $ok = $self->ok( 0, $name );
1335 $self->diag(" '$regex' doesn't look much like a regex to me.");
1336 return $ok;
1337 }
1338
1339 {
1340 ## no critic (BuiltinFunctions::ProhibitStringyEval)
1341
1342 my $test;
1343 my $context = $self->_caller_context;
1344
1345 local( $@, $!, $SIG{__DIE__} ); # isolate eval
1346
1347 $test = eval $context . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
1348
1349 $test = !$test if $cmp eq '!~';
1350
1351 local $Level = $Level + 1;
1352 $ok = $self->ok( $test, $name );
1353 }
1354
1355 unless($ok) {
1356 $this = defined $this ? "'$this'" : 'undef';
1357 my $match = $cmp eq '=~' ? "doesn't match" : "matches";
1358
1359 local $Level = $Level + 1;
1360 $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex );
1361 %s
1362 %13s '%s'
1363DIAGNOSTIC
1364
1365 }
1366
1367 return $ok;
1368}
1369
1370# I'm not ready to publish this. It doesn't deal with array return
1371# values from the code or context.
1372
1373=begin private
1374
1375=item B<_try>
1376
1377 my $return_from_code = $Test->try(sub { code });
1378 my($return_from_code, $error) = $Test->try(sub { code });
1379
1380Works like eval BLOCK except it ensures it has no effect on the rest
1381of the test (ie. C<$@> is not set) nor is effected by outside
1382interference (ie. C<$SIG{__DIE__}>) and works around some quirks in older
1383Perls.
1384
1385C<$error> is what would normally be in C<$@>.
1386
1387It is suggested you use this in place of eval BLOCK.
1388
1389=cut
1390
1391
# spent 342µs (292+51) within Test::Builder::_try which was called 17 times, avg 20µs/call: # 8 times (146µs+20µs) by Test::Builder::_unoverload at line 812, avg 21µs/call # 8 times (105µs+14µs) by Test::Builder::_is_object at line 828, avg 15µs/call # once (41µs+17µs) by Test::More::isa_ok at line 587 of Test/More.pm
sub _try {
13921721µs my( $self, $code, %opts ) = @_;
1393
1394173µs my $error;
1395171µs my $return;
1396 {
13973443µs local $!; # eval can mess up $!
1398172µs local $@; # don't set $@ in the test
13991736µs local $SIG{__DIE__}; # don't trip an outside DIE handler.
14003448µs1751µs $return = eval { $code->() };
# spent 20µs making 8 calls to Test::Builder::__ANON__[Test/Builder.pm:812], avg 3µs/call # spent 17µs making 1 call to Test::More::__ANON__[Test/More.pm:587] # spent 14µs making 8 calls to Test::Builder::__ANON__[Test/Builder.pm:828], avg 2µs/call
14011737µs $error = $@;
1402 }
1403
1404174µs die $error if $error and $opts{die_on_fail};
1405
14061760µs return wantarray ? ( $return, $error ) : $return;
1407}
1408
1409=end private
1410
1411
1412=item B<is_fh>
1413
1414 my $is_fh = $Test->is_fh($thing);
1415
1416Determines if the given C<$thing> can be used as a filehandle.
1417
1418=cut
1419
1420
# spent 11µs within Test::Builder::is_fh which was called 3 times, avg 4µs/call: # 3 times (11µs+0s) by Test::Builder::_new_fh at line 1766, avg 4µs/call
sub is_fh {
142131µs my $self = shift;
14223600ns my $maybe_fh = shift;
14233800ns return 0 unless defined $maybe_fh;
1424
1425323µs return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
1426 return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
1427
1428 return eval { $maybe_fh->isa("IO::Handle") } ||
1429 eval { tied($maybe_fh)->can('TIEHANDLE') };
1430}
1431
1432=back
1433
1434
1435=head2 Test style
1436
1437
1438=over 4
1439
1440=item B<level>
1441
1442 $Test->level($how_high);
1443
1444How far up the call stack should C<$Test> look when reporting where the
1445test failed.
1446
1447Defaults to 1.
1448
1449Setting L<$Test::Builder::Level> overrides. This is typically useful
1450localized:
1451
1452 sub my_ok {
1453 my $test = shift;
1454
1455 local $Test::Builder::Level = $Test::Builder::Level + 1;
1456 $TB->ok($test);
1457 }
1458
1459To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant.
1460
1461=cut
1462
1463
# spent 28µs within Test::Builder::level which was called 12 times, avg 2µs/call: # 12 times (28µs+0s) by Test::Builder::caller at line 2228, avg 2µs/call
sub level {
1464127µs my( $self, $level ) = @_;
1465
1466123µs if( defined $level ) {
1467 $Level = $level;
1468 }
14691234µs return $Level;
1470}
1471
1472=item B<use_numbers>
1473
1474 $Test->use_numbers($on_or_off);
1475
1476Whether or not the test should output numbers. That is, this if true:
1477
1478 ok 1
1479 ok 2
1480 ok 3
1481
1482or this if false
1483
1484 ok
1485 ok
1486 ok
1487
1488Most useful when you can't depend on the test output order, such as
1489when threads or forking is involved.
1490
1491Defaults to on.
1492
1493=cut
1494
1495
# spent 17µs within Test::Builder::use_numbers which was called 4 times, avg 4µs/call: # 4 times (17µs+0s) by Test::Builder::ok at line 747, avg 4µs/call
sub use_numbers {
149643µs my( $self, $use_nums ) = @_;
1497
149843µs if( defined $use_nums ) {
1499 $self->{Use_Nums} = $use_nums;
1500 }
1501416µs return $self->{Use_Nums};
1502}
1503
1504=item B<no_diag>
1505
1506 $Test->no_diag($no_diag);
1507
1508If set true no diagnostics will be printed. This includes calls to
1509C<diag()>.
1510
1511=item B<no_ending>
1512
1513 $Test->no_ending($no_ending);
1514
1515Normally, Test::Builder does some extra diagnostics when the test
1516ends. It also changes the exit code as described below.
1517
1518If this is true, none of that will be done.
1519
1520=item B<no_header>
1521
1522 $Test->no_header($no_header);
1523
1524If set to true, no "1..N" header will be printed.
1525
1526=cut
1527
152812µsforeach my $attribute (qw(No_Header No_Ending No_Diag)) {
152937µs my $method = lc $attribute;
1530
1531
# spent 11µs within Test::Builder::__ANON__[/usr/local/lib/perl5/5.10.1/Test/Builder.pm:1538] which was called 2 times, avg 6µs/call: # once (7µs+0s) by Test::Builder::_ending at line 2314 # once (4µs+0s) by Test::Builder::expected_tests at line 483
my $code = sub {
153223µs my( $self, $no ) = @_;
1533
15342800ns if( defined $no ) {
1535 $self->{$attribute} = $no;
1536 }
1537214µs return $self->{$attribute};
1538310µs };
1539
154031.19ms235µs
# spent 21µs (7+14) within Test::Builder::BEGIN@1540 which was called # once (7µs+14µs) by Test::Builder::Module::BEGIN@5 at line 1540
no strict 'refs'; ## no critic
# spent 21µs making 1 call to Test::Builder::BEGIN@1540 # spent 14µs making 1 call to strict::unimport
1541314µs *{ __PACKAGE__ . '::' . $method } = $code;
1542}
1543
1544=back
1545
1546=head2 Output
1547
1548Controlling where the test output goes.
1549
1550It's ok for your test to change where STDOUT and STDERR point to,
1551Test::Builder's default output settings will not be affected.
1552
1553=over 4
1554
1555=item B<diag>
1556
1557 $Test->diag(@msgs);
1558
1559Prints out the given C<@msgs>. Like C<print>, arguments are simply
1560appended together.
1561
1562Normally, it uses the C<failure_output()> handle, but if this is for a
1563TODO test, the C<todo_output()> handle is used.
1564
1565Output will be indented and marked with a # so as not to interfere
1566with test output. A newline will be put on the end if there isn't one
1567already.
1568
1569We encourage using this rather than calling print directly.
1570
1571Returns false. Why? Because C<diag()> is often used in conjunction with
1572a failing test (C<ok() || diag()>) it "passes through" the failure.
1573
1574 return ok(...) || diag(...);
1575
1576=for blame transfer
1577Mark Fowler <mark@twoshortplanks.com>
1578
1579=cut
1580
1581sub diag {
1582 my $self = shift;
1583
1584 $self->_print_comment( $self->_diag_fh, @_ );
1585}
1586
1587=item B<note>
1588
1589 $Test->note(@msgs);
1590
1591Like C<diag()>, but it prints to the C<output()> handle so it will not
1592normally be seen by the user except in verbose mode.
1593
1594=cut
1595
1596sub note {
1597 my $self = shift;
1598
1599 $self->_print_comment( $self->output, @_ );
1600}
1601
1602sub _diag_fh {
1603 my $self = shift;
1604
1605 local $Level = $Level + 1;
1606 return $self->in_todo ? $self->todo_output : $self->failure_output;
1607}
1608
1609sub _print_comment {
1610 my( $self, $fh, @msgs ) = @_;
1611
1612 return if $self->no_diag;
1613 return unless @msgs;
1614
1615 # Prevent printing headers when compiling (i.e. -c)
1616 return if $^C;
1617
1618 # Smash args together like print does.
1619 # Convert undef to 'undef' so its readable.
1620 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1621
1622 # Escape the beginning, _print will take care of the rest.
1623 $msg =~ s/^/# /;
1624
1625 local $Level = $Level + 1;
1626 $self->_print_to_fh( $fh, $msg );
1627
1628 return 0;
1629}
1630
1631=item B<explain>
1632
1633 my @dump = $Test->explain(@msgs);
1634
1635Will dump the contents of any references in a human readable format.
1636Handy for things like...
1637
1638 is_deeply($have, $want) || diag explain $have;
1639
1640or
1641
1642 is_deeply($have, $want) || note explain $have;
1643
1644=cut
1645
1646sub explain {
1647 my $self = shift;
1648
1649 return map {
1650 ref $_
1651 ? do {
1652 $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
1653
1654 my $dumper = Data::Dumper->new( [$_] );
1655 $dumper->Indent(1)->Terse(1);
1656 $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
1657 $dumper->Dump;
1658 }
1659 : $_
1660 } @_;
1661}
1662
1663=begin _private
1664
1665=item B<_print>
1666
1667 $Test->_print(@msgs);
1668
1669Prints to the C<output()> filehandle.
1670
1671=end _private
1672
1673=cut
1674
1675
# spent 367µs (53+315) within Test::Builder::_print which was called 5 times, avg 73µs/call: # 4 times (43µs+249µs) by Test::Builder::ok at line 771, avg 73µs/call # once (9µs+65µs) by Test::Builder::_output_plan at line 539
sub _print {
167652µs my $self = shift;
1677543µs10315µs return $self->_print_to_fh( $self->output, @_ );
# spent 293µs making 5 calls to Test::Builder::_print_to_fh, avg 59µs/call # spent 22µs making 5 calls to Test::Builder::output, avg 4µs/call
1678}
1679
1680
# spent 293µs (150+143) within Test::Builder::_print_to_fh which was called 5 times, avg 59µs/call: # 5 times (150µs+143µs) by Test::Builder::_print at line 1677, avg 59µs/call
sub _print_to_fh {
168159µs my( $self, $fh, @msgs ) = @_;
1682
1683 # Prevent printing headers when only compiling. Mostly for when
1684 # tests are deparsed with B::Deparse
168557µs return if $^C;
1686
1687510µs my $msg = join '', @msgs;
1688
1689527µs local( $\, $", $, ) = ( undef, ' ', '' );
1690
1691 # Escape each line after the first with a # so we don't
1692 # confuse Test::Harness.
1693536µs517µs $msg =~ s{\n(?!\z)}{\n# }sg;
# spent 17µs making 5 calls to Test::Builder::CORE:subst, avg 3µs/call
1694
1695 # Stick a newline on the end if it needs it.
1696519µs57µs $msg .= "\n" unless $msg =~ /\n\z/;
# spent 7µs making 5 calls to Test::Builder::CORE:match, avg 1µs/call
1697
16985157µs10119µs return print $fh $self->_indent, $msg;
# spent 93µs making 5 calls to Test::Builder::CORE:print, avg 19µs/call # spent 26µs making 5 calls to Test::Builder::_indent, avg 5µs/call
1699}
1700
1701=item B<output>
1702
1703=item B<failure_output>
1704
1705=item B<todo_output>
1706
1707 my $filehandle = $Test->output;
1708 $Test->output($filehandle);
1709 $Test->output($filename);
1710 $Test->output(\$scalar);
1711
1712These methods control where Test::Builder will print its output.
1713They take either an open C<$filehandle>, a C<$filename> to open and write to
1714or a C<$scalar> reference to append to. It will always return a C<$filehandle>.
1715
1716B<output> is where normal "ok/not ok" test output goes.
1717
1718Defaults to STDOUT.
1719
1720B<failure_output> is where diagnostic output on test failures and
1721C<diag()> goes. It is normally not read by Test::Harness and instead is
1722displayed to the user.
1723
1724Defaults to STDERR.
1725
1726C<todo_output> is used instead of C<failure_output()> for the
1727diagnostics of a failing TODO test. These will not be seen by the
1728user.
1729
1730Defaults to STDOUT.
1731
1732=cut
1733
1734
# spent 54µs (32+22) within Test::Builder::output which was called 6 times, avg 9µs/call: # 5 times (22µs+0s) by Test::Builder::_print at line 1677, avg 4µs/call # once (10µs+22µs) by Test::Builder::reset_outputs at line 1862
sub output {
173566µs my( $self, $fh ) = @_;
1736
173765µs122µs if( defined $fh ) {
# spent 22µs making 1 call to Test::Builder::_new_fh
1738 $self->{Out_FH} = $self->_new_fh($fh);
1739 }
1740625µs return $self->{Out_FH};
1741}
1742
1743
# spent 19µs (9+10) within Test::Builder::failure_output which was called # once (9µs+10µs) by Test::Builder::reset_outputs at line 1863
sub failure_output {
17441800ns my( $self, $fh ) = @_;
1745
174612µs110µs if( defined $fh ) {
# spent 10µs making 1 call to Test::Builder::_new_fh
1747 $self->{Fail_FH} = $self->_new_fh($fh);
1748 }
1749112µs return $self->{Fail_FH};
1750}
1751
1752
# spent 18µs (8+10) within Test::Builder::todo_output which was called # once (8µs+10µs) by Test::Builder::reset_outputs at line 1864
sub todo_output {
17531800ns my( $self, $fh ) = @_;
1754
175512µs110µs if( defined $fh ) {
# spent 10µs making 1 call to Test::Builder::_new_fh
1756 $self->{Todo_FH} = $self->_new_fh($fh);
1757 }
175815µs return $self->{Todo_FH};
1759}
1760
1761
# spent 42µs (31+11) within Test::Builder::_new_fh which was called 3 times, avg 14µs/call: # once (18µs+5µs) by Test::Builder::output at line 1737 # once (7µs+3µs) by Test::Builder::failure_output at line 1746 # once (7µs+3µs) by Test::Builder::todo_output at line 1755
sub _new_fh {
176231µs my $self = shift;
176331µs my($file_or_fh) = shift;
1764
17653600ns my $fh;
176635µs311µs if( $self->is_fh($file_or_fh) ) {
# spent 11µs making 3 calls to Test::Builder::is_fh, avg 4µs/call
1767 $fh = $file_or_fh;
1768 }
1769 elsif( ref $file_or_fh eq 'SCALAR' ) {
1770 # Scalar refs as filehandles was added in 5.8.
1771 if( $] >= 5.008 ) {
1772 open $fh, ">>", $file_or_fh
1773 or $self->croak("Can't open scalar ref $file_or_fh: $!");
1774 }
1775 # Emulate scalar ref filehandles with a tie.
1776 else {
1777 $fh = Test::Builder::IO::Scalar->new($file_or_fh)
1778 or $self->croak("Can't tie scalar ref $file_or_fh");
1779 }
1780 }
1781 else {
1782 open $fh, ">", $file_or_fh
1783 or $self->croak("Can't open test output log $file_or_fh: $!");
1784 _autoflush($fh);
1785 }
1786
1787314µs return $fh;
1788}
1789
1790
# spent 58µs (45+13) within Test::Builder::_autoflush which was called 4 times, avg 15µs/call: # once (19µs+9µs) by Test::Builder::_dup_stdhandles at line 1808 # once (10µs+2µs) by Test::Builder::_dup_stdhandles at line 1809 # once (9µs+1µs) by Test::Builder::_dup_stdhandles at line 1810 # once (8µs+1µs) by Test::Builder::_dup_stdhandles at line 1811
sub _autoflush {
179142µs my($fh) = shift;
1792426µs410µs my $old_fh = select $fh;
# spent 10µs making 4 calls to Test::Builder::CORE:select, avg 2µs/call
179344µs $| = 1;
1794417µs43µs select $old_fh;
# spent 3µs making 4 calls to Test::Builder::CORE:select, avg 750ns/call
1795
1796417µs return;
1797}
1798
17991400nsmy( $Testout, $Testerr );
1800
1801
# spent 290µs (32+258) within Test::Builder::_dup_stdhandles which was called # once (32µs+258µs) by Test::Builder::reset at line 377
sub _dup_stdhandles {
18021500ns my $self = shift;
1803
180412µs1105µs $self->_open_testhandles;
# spent 105µs making 1 call to Test::Builder::_open_testhandles
1805
1806 # Set everything to unbuffered else plain prints to STDOUT will
1807 # come out in the wrong order from our own prints.
180813µs128µs _autoflush($Testout);
# spent 28µs making 1 call to Test::Builder::_autoflush
180912µs111µs _autoflush( \*STDOUT );
# spent 11µs making 1 call to Test::Builder::_autoflush
181012µs110µs _autoflush($Testerr);
# spent 10µs making 1 call to Test::Builder::_autoflush
181112µs19µs _autoflush( \*STDERR );
# spent 9µs making 1 call to Test::Builder::_autoflush
1812
181312µs194µs $self->reset_outputs;
# spent 94µs making 1 call to Test::Builder::reset_outputs
1814
181514µs return;
1816}
1817
1818
# spent 105µs (24+81) within Test::Builder::_open_testhandles which was called # once (24µs+81µs) by Test::Builder::_dup_stdhandles at line 1804
sub _open_testhandles {
18191300ns my $self = shift;
1820
18211500ns return if $self->{Opened_Testhandles};
1822
1823 # We dup STDOUT and STDERR so people can change them in their
1824 # test suites while still getting normal test output.
1825174µs163µs open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
# spent 63µs making 1 call to Test::Builder::CORE:open
1826126µs118µs open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!";
# spent 18µs making 1 call to Test::Builder::CORE:open
1827
1828 # $self->_copy_io_layers( \*STDOUT, $Testout );
1829 # $self->_copy_io_layers( \*STDERR, $Testerr );
1830
183111µs $self->{Opened_Testhandles} = 1;
1832
183316µs return;
1834}
1835
1836sub _copy_io_layers {
1837 my( $self, $src, $dst ) = @_;
1838
1839 $self->_try(
1840 sub {
1841 require PerlIO;
1842 my @src_layers = PerlIO::get_layers($src);
1843
1844 binmode $dst, join " ", map ":$_", @src_layers if @src_layers;
1845 }
1846 );
1847
1848 return;
1849}
1850
1851=item reset_outputs
1852
1853 $tb->reset_outputs;
1854
1855Resets all the output filehandles back to their defaults.
1856
1857=cut
1858
1859
# spent 94µs (25+69) within Test::Builder::reset_outputs which was called # once (25µs+69µs) by Test::Builder::_dup_stdhandles at line 1813
sub reset_outputs {
18601500ns my $self = shift;
1861
186212µs132µs $self->output ($Testout);
# spent 32µs making 1 call to Test::Builder::output
186312µs119µs $self->failure_output($Testerr);
# spent 19µs making 1 call to Test::Builder::failure_output
186412µs118µs $self->todo_output ($Testout);
# spent 18µs making 1 call to Test::Builder::todo_output
1865
186614µs return;
1867}
1868
1869=item carp
1870
1871 $tb->carp(@message);
1872
1873Warns with C<@message> but the message will appear to come from the
1874point where the original test function was called (C<< $tb->caller >>).
1875
1876=item croak
1877
1878 $tb->croak(@message);
1879
1880Dies with C<@message> but the message will appear to come from the
1881point where the original test function was called (C<< $tb->caller >>).
1882
1883=cut
1884
1885sub _message_at_caller {
1886 my $self = shift;
1887
1888 local $Level = $Level + 1;
1889 my( $pack, $file, $line ) = $self->caller;
1890 return join( "", @_ ) . " at $file line $line.\n";
1891}
1892
1893sub carp {
1894 my $self = shift;
1895 return warn $self->_message_at_caller(@_);
1896}
1897
1898sub croak {
1899 my $self = shift;
1900 return die $self->_message_at_caller(@_);
1901}
1902
1903
1904=back
1905
1906
1907=head2 Test Status and Info
1908
1909=over 4
1910
1911=item B<current_test>
1912
1913 my $curr_test = $Test->current_test;
1914 $Test->current_test($num);
1915
1916Gets/sets the current test number we're on. You usually shouldn't
1917have to set this.
1918
1919If set forward, the details of the missing tests are filled in as 'unknown'.
1920if set backward, the details of the intervening tests are deleted. You
1921can erase history if you really want to.
1922
1923=cut
1924
1925sub current_test {
1926 my( $self, $num ) = @_;
1927
1928 lock( $self->{Curr_Test} );
1929 if( defined $num ) {
1930 $self->{Curr_Test} = $num;
1931
1932 # If the test counter is being pushed forward fill in the details.
1933 my $test_results = $self->{Test_Results};
1934 if( $num > @$test_results ) {
1935 my $start = @$test_results ? @$test_results : 0;
1936 for( $start .. $num - 1 ) {
1937 $test_results->[$_] = &share(
1938 {
1939 'ok' => 1,
1940 actual_ok => undef,
1941 reason => 'incrementing test number',
1942 type => 'unknown',
1943 name => undef
1944 }
1945 );
1946 }
1947 }
1948 # If backward, wipe history. Its their funeral.
1949 elsif( $num < @$test_results ) {
1950 $#{$test_results} = $num - 1;
1951 }
1952 }
1953 return $self->{Curr_Test};
1954}
1955
1956=item B<is_passing>
1957
1958 my $ok = $builder->is_passing;
1959
1960Indicates if the test suite is currently passing.
1961
1962More formally, it will be false if anything has happened which makes
1963it impossible for the test suite to pass. True otherwise.
1964
1965For example, if no tests have run C<is_passing()> will be true because
1966even though a suite with no tests is a failure you can add a passing
1967test to it and start passing.
1968
1969Don't think about it too much.
1970
1971=cut
1972
1973
# spent 4µs within Test::Builder::is_passing which was called # once (4µs+0s) by Test::Builder::reset at line 348
sub is_passing {
19741400ns my $self = shift;
1975
197611µs if( @_ ) {
1977 $self->{Is_Passing} = shift;
1978 }
1979
1980111µs return $self->{Is_Passing};
1981}
1982
1983
1984=item B<summary>
1985
1986 my @tests = $Test->summary;
1987
1988A simple summary of the tests so far. True for pass, false for fail.
1989This is a logical pass/fail, so todos are passes.
1990
1991Of course, test #1 is $tests[0], etc...
1992
1993=cut
1994
1995sub summary {
1996 my($self) = shift;
1997
1998 return map { $_->{'ok'} } @{ $self->{Test_Results} };
1999}
2000
2001=item B<details>
2002
2003 my @tests = $Test->details;
2004
2005Like C<summary()>, but with a lot more detail.
2006
2007 $tests[$test_num - 1] =
2008 { 'ok' => is the test considered a pass?
2009 actual_ok => did it literally say 'ok'?
2010 name => name of the test (if any)
2011 type => type of test (if any, see below).
2012 reason => reason for the above (if any)
2013 };
2014
2015'ok' is true if Test::Harness will consider the test to be a pass.
2016
2017'actual_ok' is a reflection of whether or not the test literally
2018printed 'ok' or 'not ok'. This is for examining the result of 'todo'
2019tests.
2020
2021'name' is the name of the test.
2022
2023'type' indicates if it was a special test. Normal tests have a type
2024of ''. Type can be one of the following:
2025
2026 skip see skip()
2027 todo see todo()
2028 todo_skip see todo_skip()
2029 unknown see below
2030
2031Sometimes the Test::Builder test counter is incremented without it
2032printing any test output, for example, when C<current_test()> is changed.
2033In these cases, Test::Builder doesn't know the result of the test, so
2034its type is 'unknown'. These details for these tests are filled in.
2035They are considered ok, but the name and actual_ok is left C<undef>.
2036
2037For example "not ok 23 - hole count # TODO insufficient donuts" would
2038result in this structure:
2039
2040 $tests[22] = # 23 - 1, since arrays start from 0.
2041 { ok => 1, # logically, the test passed since its todo
2042 actual_ok => 0, # in absolute terms, it failed
2043 name => 'hole count',
2044 type => 'todo',
2045 reason => 'insufficient donuts'
2046 };
2047
2048=cut
2049
2050sub details {
2051 my $self = shift;
2052 return @{ $self->{Test_Results} };
2053}
2054
2055=item B<todo>
2056
2057 my $todo_reason = $Test->todo;
2058 my $todo_reason = $Test->todo($pack);
2059
2060If the current tests are considered "TODO" it will return the reason,
2061if any. This reason can come from a C<$TODO> variable or the last call
2062to C<todo_start()>.
2063
2064Since a TODO test does not need a reason, this function can return an
2065empty string even when inside a TODO block. Use C<< $Test->in_todo >>
2066to determine if you are currently inside a TODO block.
2067
2068C<todo()> is about finding the right package to look for C<$TODO> in. It's
2069pretty good at guessing the right package to look at. It first looks for
2070the caller based on C<$Level + 1>, since C<todo()> is usually called inside
2071a test function. As a last resort it will use C<exported_to()>.
2072
2073Sometimes there is some confusion about where todo() should be looking
2074for the C<$TODO> variable. If you want to be sure, tell it explicitly
2075what $pack to use.
2076
2077=cut
2078
2079
# spent 176µs (43+133) within Test::Builder::todo which was called 4 times, avg 44µs/call: # 4 times (43µs+133µs) by Test::Builder::ok at line 729, avg 44µs/call
sub todo {
208044µs my( $self, $pack ) = @_;
2081
208244µs return $self->{Todo} if defined $self->{Todo};
2083
208443µs local $Level = $Level + 1;
2085410µs4134µs my $todo = $self->find_TODO($pack);
# spent 134µs making 4 calls to Test::Builder::find_TODO, avg 33µs/call
208641µs return $todo if defined $todo;
2087
2088414µs return '';
2089}
2090
2091=item B<find_TODO>
2092
2093 my $todo_reason = $Test->find_TODO();
2094 my $todo_reason = $Test->find_TODO($pack):
2095
2096Like C<todo()> but only returns the value of C<$TODO> ignoring
2097C<todo_start()>.
2098
2099=cut
2100
2101
# spent 290µs (87+203) within Test::Builder::find_TODO which was called 12 times, avg 24µs/call: # 8 times (45µs+112µs) by Test::Builder::in_todo at line 2123, avg 20µs/call # 4 times (42µs+91µs) by Test::Builder::todo at line 2085, avg 33µs/call
sub find_TODO {
2102127µs my( $self, $pack ) = @_;
2103
21041226µs12203µs $pack = $pack || $self->caller(1) || $self->exported_to;
# spent 203µs making 12 calls to Test::Builder::caller, avg 17µs/call
2105122µs return unless $pack;
2106
2107313.4ms231µs
# spent 19µs (7+12) within Test::Builder::BEGIN@2107 which was called # once (7µs+12µs) by Test::Builder::Module::BEGIN@5 at line 2107
no strict 'refs'; ## no critic
# spent 19µs making 1 call to Test::Builder::BEGIN@2107 # spent 12µs making 1 call to strict::unimport
21081247µs return ${ $pack . '::TODO' };
2109}
2110
2111=item B<in_todo>
2112
2113 my $in_todo = $Test->in_todo;
2114
2115Returns true if the test is currently inside a TODO block.
2116
2117=cut
2118
2119
# spent 205µs (48+157) within Test::Builder::in_todo which was called 8 times, avg 26µs/call: # 4 times (21µs+82µs) by Test::Builder::ok at line 758, avg 26µs/call # 4 times (27µs+74µs) by Test::Builder::ok at line 730, avg 25µs/call
sub in_todo {
212084µs my $self = shift;
2121
212285µs local $Level = $Level + 1;
2123834µs8157µs return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
# spent 157µs making 8 calls to Test::Builder::find_TODO, avg 20µs/call
2124}
2125
2126=item B<todo_start>
2127
2128 $Test->todo_start();
2129 $Test->todo_start($message);
2130
2131This method allows you declare all subsequent tests as TODO tests, up until
2132the C<todo_end> method has been called.
2133
2134The C<TODO:> and C<$TODO> syntax is generally pretty good about figuring out
2135whether or not we're in a TODO test. However, often we find that this is not
2136possible to determine (such as when we want to use C<$TODO> but
2137the tests are being executed in other packages which can't be inferred
2138beforehand).
2139
2140Note that you can use this to nest "todo" tests
2141
2142 $Test->todo_start('working on this');
2143 # lots of code
2144 $Test->todo_start('working on that');
2145 # more code
2146 $Test->todo_end;
2147 $Test->todo_end;
2148
2149This is generally not recommended, but large testing systems often have weird
2150internal needs.
2151
2152We've tried to make this also work with the TODO: syntax, but it's not
2153guaranteed and its use is also discouraged:
2154
2155 TODO: {
2156 local $TODO = 'We have work to do!';
2157 $Test->todo_start('working on this');
2158 # lots of code
2159 $Test->todo_start('working on that');
2160 # more code
2161 $Test->todo_end;
2162 $Test->todo_end;
2163 }
2164
2165Pick one style or another of "TODO" to be on the safe side.
2166
2167=cut
2168
2169sub todo_start {
2170 my $self = shift;
2171 my $message = @_ ? shift : '';
2172
2173 $self->{Start_Todo}++;
2174 if( $self->in_todo ) {
2175 push @{ $self->{Todo_Stack} } => $self->todo;
2176 }
2177 $self->{Todo} = $message;
2178
2179 return;
2180}
2181
2182=item C<todo_end>
2183
2184 $Test->todo_end;
2185
2186Stops running tests as "TODO" tests. This method is fatal if called without a
2187preceding C<todo_start> method call.
2188
2189=cut
2190
2191sub todo_end {
2192 my $self = shift;
2193
2194 if( !$self->{Start_Todo} ) {
2195 $self->croak('todo_end() called without todo_start()');
2196 }
2197
2198 $self->{Start_Todo}--;
2199
2200 if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
2201 $self->{Todo} = pop @{ $self->{Todo_Stack} };
2202 }
2203 else {
2204 delete $self->{Todo};
2205 }
2206
2207 return;
2208}
2209
2210=item B<caller>
2211
2212 my $package = $Test->caller;
2213 my($pack, $file, $line) = $Test->caller;
2214 my($pack, $file, $line) = $Test->caller($height);
2215
2216Like the normal C<caller()>, except it reports according to your C<level()>.
2217
2218C<$height> will be added to the C<level()>.
2219
2220If C<caller()> winds up off the top of the stack it report the highest context.
2221
2222=cut
2223
2224
# spent 203µs (175+28) within Test::Builder::caller which was called 12 times, avg 17µs/call: # 12 times (175µs+28µs) by Test::Builder::find_TODO at line 2104, avg 17µs/call
sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
2225127µs my( $self, $height ) = @_;
2226123µs $height ||= 0;
2227
22281226µs1228µs my $level = $self->level + $height + 1;
# spent 28µs making 12 calls to Test::Builder::level, avg 2µs/call
2229122µs my @caller;
22301211µs do {
22311261µs @caller = CORE::caller( $level );
2232125µs $level--;
2233 } until @caller;
22341246µs return wantarray ? @caller : $caller[0];
2235}
2236
2237=back
2238
2239=cut
2240
2241=begin _private
2242
2243=over 4
2244
2245=item B<_sanity_check>
2246
2247 $self->_sanity_check();
2248
2249Runs a bunch of end of test sanity checks to make sure reality came
2250through ok. If anything is wrong it will die with a fairly friendly
2251error message.
2252
2253=cut
2254
2255#'#
2256sub _sanity_check {
2257 my $self = shift;
2258
2259 $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
2260 $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
2261 'Somehow you got a different number of results than tests ran!' );
2262
2263 return;
2264}
2265
2266=item B<_whoa>
2267
2268 $self->_whoa($check, $description);
2269
2270A sanity check, similar to C<assert()>. If the C<$check> is true, something
2271has gone horribly wrong. It will die with the given C<$description> and
2272a note to contact the author.
2273
2274=cut
2275
2276sub _whoa {
2277 my( $self, $check, $desc ) = @_;
2278 if($check) {
2279 local $Level = $Level + 1;
2280 $self->croak(<<"WHOA");
2281WHOA! $desc
2282This should never happen! Please contact the author immediately!
2283WHOA
2284 }
2285
2286 return;
2287}
2288
2289=item B<_my_exit>
2290
2291 _my_exit($exit_num);
2292
2293Perl seems to have some trouble with exiting inside an C<END> block.
22945.6.1 does some odd things. Instead, this function edits C<$?>
2295directly. It should B<only> be called from inside an C<END> block.
2296It doesn't actually exit, that's your job.
2297
2298=cut
2299
2300
# spent 4µs within Test::Builder::_my_exit which was called # once (4µs+0s) by Test::Builder::_ending at line 2403
sub _my_exit {
230111µs $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
2302
230316µs return 1;
2304}
2305
2306=back
2307
2308=end _private
2309
2310=cut
2311
2312
# spent 75µs (60+15) within Test::Builder::_ending which was called # once (60µs+15µs) by Test::Builder::END at line 2426
sub _ending {
231311µs my $self = shift;
231414µs17µs return if $self->no_ending;
# spent 7µs making 1 call to Test::Builder::__ANON__[Test/Builder.pm:1538]
231511µs return if $self->{Ending}++;
2316
231712µs my $real_exit_code = $?;
2318
2319 # Don't bother with an ending if this is a forked copy. Only the parent
2320 # should do the ending.
232112µs if( $self->{Original_Pid} != $$ ) {
2322 return;
2323 }
2324
2325 # Ran tests but never declared a plan or hit done_testing
232611µs if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
2327 $self->is_passing(0);
2328 $self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
2329 }
2330
2331 # Exit if plan() was never called. This is so "require Test::Simple"
2332 # doesn't puke.
23331600ns if( !$self->{Have_Plan} ) {
2334 return;
2335 }
2336
2337 # Don't do an ending if we bailed out.
233811µs if( $self->{Bailed_Out} ) {
2339 $self->is_passing(0);
2340 return;
2341 }
2342 # Figure out if we passed or failed and print helpful messages.
234311µs my $test_results = $self->{Test_Results};
23441900ns if(@$test_results) {
2345 # The plan? We have no plan.
23461600ns if( $self->{No_Plan} ) {
2347 $self->_output_plan($self->{Curr_Test}) unless $self->no_header;
2348 $self->{Expected_Tests} = $self->{Curr_Test};
2349 }
2350
2351 # Auto-extended arrays and elements which aren't explicitly
2352 # filled in with a shared reference will puke under 5.8.0
2353 # ithreads. So we have to fill them in by hand. :(
235414µs14µs my $empty_result = &share( {} );
# spent 4µs making 1 call to Test::Builder::__ANON__[Test/Builder.pm:66]
235514µs for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
235643µs $test_results->[$idx] = $empty_result
2357 unless defined $test_results->[$idx];
2358 }
2359
236018µs my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
2361
236211µs my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
2363
23641600ns if( $num_extra != 0 ) {
2365 my $s = $self->{Expected_Tests} == 1 ? '' : 's';
2366 $self->diag(<<"FAIL");
2367Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}.
2368FAIL
2369 $self->is_passing(0);
2370 }
2371
23721500ns if($num_failed) {
2373 my $num_tests = $self->{Curr_Test};
2374 my $s = $num_failed == 1 ? '' : 's';
2375
2376 my $qualifier = $num_extra == 0 ? '' : ' run';
2377
2378 $self->diag(<<"FAIL");
2379Looks like you failed $num_failed test$s of $num_tests$qualifier.
2380FAIL
2381 $self->is_passing(0);
2382 }
2383
23841400ns if($real_exit_code) {
2385 $self->diag(<<"FAIL");
2386Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
2387FAIL
2388 $self->is_passing(0);
2389 _my_exit($real_exit_code) && return;
2390 }
2391
23921300ns my $exit_code;
239311µs if($num_failed) {
2394 $exit_code = $num_failed <= 254 ? $num_failed : 254;
2395 }
2396 elsif( $num_extra != 0 ) {
2397 $exit_code = 255;
2398 }
2399 else {
24001500ns $exit_code = 0;
2401 }
2402
240319µs14µs _my_exit($exit_code) && return;
# spent 4µs making 1 call to Test::Builder::_my_exit
2404 }
2405 elsif( $self->{Skip_All} ) {
2406 _my_exit(0) && return;
2407 }
2408 elsif($real_exit_code) {
2409 $self->diag(<<"FAIL");
2410Looks like your test exited with $real_exit_code before it could output anything.
2411FAIL
2412 $self->is_passing(0);
2413 _my_exit($real_exit_code) && return;
2414 }
2415 else {
2416 $self->diag("No tests run!\n");
2417 $self->is_passing(0);
2418 _my_exit(255) && return;
2419 }
2420
2421 $self->is_passing(0);
2422 $self->_whoa( 1, "We fell off the end of _ending()" );
2423}
2424
2425
# spent 88µs (13+75) within Test::Builder::END which was called # once (13µs+75µs) by main::RUNTIME at line 0 of 01.HTTP.t
END {
242619µs175µs $Test->_ending if defined $Test;
# spent 75µs making 1 call to Test::Builder::_ending
2427}
2428
2429=head1 EXIT CODES
2430
2431If all your tests passed, Test::Builder will exit with zero (which is
2432normal). If anything failed it will exit with how many failed. If
2433you run less (or more) tests than you planned, the missing (or extras)
2434will be considered failures. If no tests were ever run Test::Builder
2435will throw a warning and exit with 255. If the test died, even after
2436having successfully completed all its tests, it will still be
2437considered a failure and will exit with 255.
2438
2439So the exit codes are...
2440
2441 0 all tests successful
2442 255 test died or all passed but wrong # of tests run
2443 any other number how many failed (including missing or extras)
2444
2445If you fail more than 254 tests, it will be reported as 254.
2446
2447=head1 THREADS
2448
2449In perl 5.8.1 and later, Test::Builder is thread-safe. The test
2450number is shared amongst all threads. This means if one thread sets
2451the test number using C<current_test()> they will all be effected.
2452
2453While versions earlier than 5.8.1 had threads they contain too many
2454bugs to support.
2455
2456Test::Builder is only thread-aware if threads.pm is loaded I<before>
2457Test::Builder.
2458
2459=head1 MEMORY
2460
2461An informative hash, accessable via C<<details()>>, is stored for each
2462test you perform. So memory usage will scale linearly with each test
2463run. Although this is not a problem for most test suites, it can
2464become an issue if you do large (hundred thousands to million)
2465combinatorics tests in the same run.
2466
2467In such cases, you are advised to either split the test file into smaller
2468ones, or use a reverse approach, doing "normal" (code) compares and
2469triggering fail() should anything go unexpected.
2470
2471Future versions of Test::Builder will have a way to turn history off.
2472
2473
2474=head1 EXAMPLES
2475
2476CPAN can provide the best examples. Test::Simple, Test::More,
2477Test::Exception and Test::Differences all use Test::Builder.
2478
2479=head1 SEE ALSO
2480
2481Test::Simple, Test::More, Test::Harness
2482
2483=head1 AUTHORS
2484
2485Original code by chromatic, maintained by Michael G Schwern
2486E<lt>schwern@pobox.comE<gt>
2487
2488=head1 COPYRIGHT
2489
2490Copyright 2002-2008 by chromatic E<lt>chromatic@wgz.orgE<gt> and
2491 Michael G Schwern E<lt>schwern@pobox.comE<gt>.
2492
2493This program is free software; you can redistribute it and/or
2494modify it under the same terms as Perl itself.
2495
2496See F<http://www.perl.com/perl/misc/Artistic.html>
2497
2498=cut
2499
2500146µs1;
2501
# spent 33µs within Test::Builder::CORE:match which was called 14 times, avg 2µs/call: # 5 times (7µs+0s) by Test::Builder::_print_to_fh at line 1696 of Test/Builder.pm, avg 1µs/call # 4 times (12µs+0s) by Test::Builder::ok at line 722 of Test/Builder.pm, avg 3µs/call # 4 times (5µs+0s) by Test::Builder::_check_is_passing_plan at line 803 of Test/Builder.pm, avg 1µs/call # once (9µs+0s) by Test::Builder::expected_tests at line 477 of Test/Builder.pm
sub Test::Builder::CORE:match; # xsub
# spent 81µs within Test::Builder::CORE:open which was called 2 times, avg 41µs/call: # once (63µs+0s) by Test::Builder::_open_testhandles at line 1825 of Test/Builder.pm # once (18µs+0s) by Test::Builder::_open_testhandles at line 1826 of Test/Builder.pm
sub Test::Builder::CORE:open; # xsub
# spent 93µs within Test::Builder::CORE:print which was called 5 times, avg 19µs/call: # 5 times (93µs+0s) by Test::Builder::_print_to_fh at line 1698 of Test/Builder.pm, avg 19µs/call
sub Test::Builder::CORE:print; # xsub
# spent 13µs within Test::Builder::CORE:select which was called 8 times, avg 2µs/call: # 4 times (10µs+0s) by Test::Builder::_autoflush at line 1792 of Test/Builder.pm, avg 2µs/call # 4 times (3µs+0s) by Test::Builder::_autoflush at line 1794 of Test/Builder.pm, avg 750ns/call
sub Test::Builder::CORE:select; # xsub
# spent 21µs within Test::Builder::CORE:subst which was called 9 times, avg 2µs/call: # 5 times (17µs+0s) by Test::Builder::_print_to_fh at line 1693 of Test/Builder.pm, avg 3µs/call # 4 times (4µs+0s) by Test::Builder::ok at line 750 of Test/Builder.pm, avg 1µs/call
sub Test::Builder::CORE:subst; # xsub