Profile of Test/Builder.pm

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

Filename | /home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1/Test/Builder.pm
Statements | Executed 4306 statements in 77.4ms

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