Filename | /home/ss5/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1/Test/Builder.pm |
Statements | Executed 4306 statements in 77.4ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
20 | 2 | 2 | 5.73ms | 34.2ms | ok | Test::Builder::
82 | 3 | 1 | 5.26ms | 7.09ms | _try | Test::Builder::
63 | 2 | 1 | 4.00ms | 4.73ms | caller | Test::Builder::
1 | 1 | 1 | 2.72ms | 5.61ms | BEGIN@19 | Test::Builder::
40 | 1 | 1 | 2.69ms | 9.80ms | _unoverload | Test::Builder::
22 | 2 | 1 | 2.47ms | 5.84ms | _print_to_fh | Test::Builder::
22 | 1 | 1 | 2.04ms | 2.04ms | CORE:print (opcode) | Test::Builder::
61 | 2 | 1 | 1.88ms | 6.31ms | find_TODO | Test::Builder::
40 | 1 | 1 | 1.45ms | 3.40ms | _is_object | Test::Builder::
20 | 1 | 1 | 1.08ms | 4.07ms | todo | Test::Builder::
2 | 1 | 1 | 1.08ms | 1.26ms | __ANON__[:1906] | Test::Builder::
42 | 2 | 1 | 1.07ms | 1.07ms | CORE:match (opcode) | Test::Builder::
2 | 1 | 1 | 859µs | 4.42ms | cmp_ok | Test::Builder::
41 | 3 | 1 | 833µs | 4.16ms | in_todo | Test::Builder::
40 | 2 | 1 | 828µs | 10.6ms | _unoverload_str | Test::Builder::
21 | 2 | 1 | 815µs | 7.09ms | _print | Test::Builder::
63 | 1 | 1 | 728µs | 728µs | level | Test::Builder::
22 | 2 | 1 | 661µs | 699µs | output | Test::Builder::
43 | 3 | 1 | 659µs | 659µs | CORE:subst (opcode) | Test::Builder::
22 | 1 | 1 | 623µs | 623µs | _indent | Test::Builder::
20 | 1 | 1 | 543µs | 784µs | _check_is_passing_plan | Test::Builder::
21 | 2 | 1 | 383µs | 383µs | __ANON__[:67] | Test::Builder::
23 | 4 | 1 | 356µs | 356µs | __ANON__[:66] | Test::Builder::
40 | 1 | 1 | 341µs | 341µs | __ANON__[:871] | Test::Builder::
20 | 1 | 1 | 262µs | 262µs | use_numbers | Test::Builder::
1 | 1 | 1 | 254µs | 295µs | _ending | Test::Builder::
20 | 1 | 1 | 241µs | 241µs | has_plan | Test::Builder::
40 | 1 | 1 | 232µs | 232µs | __ANON__[:887] | Test::Builder::
7 | 3 | 3 | 209µs | 2.60ms | new | Test::Builder::
1 | 1 | 1 | 155µs | 449µs | done_testing | Test::Builder::
1 | 1 | 1 | 151µs | 2.35ms | reset | Test::Builder::
2 | 1 | 1 | 133µs | 4.55ms | isnt_eq | Test::Builder::
2 | 2 | 1 | 129µs | 129µs | CORE:open (opcode) | Test::Builder::
1 | 1 | 1 | 114µs | 361µs | _print_comment | Test::Builder::
4 | 4 | 1 | 104µs | 134µs | _autoflush | Test::Builder::
1 | 1 | 1 | 101µs | 1.74ms | _open_testhandles | Test::Builder::
2 | 1 | 1 | 96µs | 145µs | _apply_layers | Test::Builder::
1 | 1 | 1 | 92µs | 108µs | BEGIN@18 | Test::Builder::
2 | 2 | 1 | 87µs | 1.51ms | _copy_io_layers | Test::Builder::
1 | 1 | 1 | 85µs | 85µs | BEGIN@3 | Test::Builder::
1 | 1 | 1 | 81µs | 2.17ms | _dup_stdhandles | Test::Builder::
1 | 1 | 1 | 72µs | 637µs | diag | Test::Builder::
1 | 1 | 1 | 64µs | 205µs | _diag_fh | Test::Builder::
1 | 1 | 1 | 62µs | 133µs | BEGIN@916 | Test::Builder::
3 | 3 | 1 | 57µs | 84µs | _new_fh | Test::Builder::
1 | 1 | 1 | 54µs | 115µs | BEGIN@1221 | Test::Builder::
1 | 1 | 1 | 54µs | 61µs | current_test | Test::Builder::
2 | 2 | 1 | 54µs | 77µs | failure_output | Test::Builder::
1 | 1 | 1 | 54µs | 209µs | reset_outputs | Test::Builder::
2 | 1 | 1 | 49µs | 49µs | CORE:binmode (opcode) | Test::Builder::
1 | 1 | 1 | 47µs | 120µs | BEGIN@2181 | Test::Builder::
1 | 1 | 1 | 47µs | 2.39ms | create | Test::Builder::
2 | 2 | 1 | 44µs | 44µs | __ANON__[:1598] | Test::Builder::
1 | 1 | 1 | 44µs | 339µs | END | Test::Builder::
1 | 1 | 1 | 42µs | 113µs | BEGIN@1600 | Test::Builder::
1 | 1 | 1 | 41µs | 213µs | _output_plan | Test::Builder::
8 | 2 | 1 | 30µs | 30µs | CORE:select (opcode) | Test::Builder::
3 | 1 | 1 | 27µs | 27µs | is_fh | Test::Builder::
1 | 1 | 1 | 27µs | 37µs | BEGIN@4 | Test::Builder::
1 | 1 | 1 | 27µs | 49µs | BEGIN@5 | Test::Builder::
1 | 1 | 1 | 22µs | 44µs | todo_output | Test::Builder::
1 | 1 | 1 | 20µs | 20µs | expected_tests | Test::Builder::
1 | 1 | 1 | 19µs | 19µs | BEGIN@10 | Test::Builder::
1 | 1 | 1 | 17µs | 17µs | exported_to | Test::Builder::
1 | 1 | 1 | 15µs | 15µs | is_passing | Test::Builder::
1 | 1 | 1 | 11µs | 11µs | _my_exit | Test::Builder::
1 | 1 | 1 | 9µs | 9µs | plan | Test::Builder::
0 | 0 | 0 | 0s | 0s | BAIL_OUT | Test::Builder::
0 | 0 | 0 | 0s | 0s | DESTROY | Test::Builder::
0 | 0 | 0 | 0s | 0s | __ANON__[:1712] | Test::Builder::
0 | 0 | 0 | 0s | 0s | __ANON__[:237] | Test::Builder::
0 | 0 | 0 | 0s | 0s | __ANON__[:61] | Test::Builder::
0 | 0 | 0 | 0s | 0s | _caller_context | Test::Builder::
0 | 0 | 0 | 0s | 0s | _cmp_diag | Test::Builder::
0 | 0 | 0 | 0s | 0s | _diag_fmt | Test::Builder::
0 | 0 | 0 | 0s | 0s | _is_diag | Test::Builder::
0 | 0 | 0 | 0s | 0s | _is_dualvar | Test::Builder::
0 | 0 | 0 | 0s | 0s | _is_qr | Test::Builder::
0 | 0 | 0 | 0s | 0s | _isnt_diag | Test::Builder::
0 | 0 | 0 | 0s | 0s | _message_at_caller | Test::Builder::
0 | 0 | 0 | 0s | 0s | _plan_handled | Test::Builder::
0 | 0 | 0 | 0s | 0s | _plan_tests | Test::Builder::
0 | 0 | 0 | 0s | 0s | _regex_ok | Test::Builder::
0 | 0 | 0 | 0s | 0s | _sanity_check | Test::Builder::
0 | 0 | 0 | 0s | 0s | _unoverload_num | Test::Builder::
0 | 0 | 0 | 0s | 0s | _whoa | Test::Builder::
0 | 0 | 0 | 0s | 0s | carp | Test::Builder::
0 | 0 | 0 | 0s | 0s | child | Test::Builder::
0 | 0 | 0 | 0s | 0s | croak | Test::Builder::
0 | 0 | 0 | 0s | 0s | details | Test::Builder::
0 | 0 | 0 | 0s | 0s | explain | Test::Builder::
0 | 0 | 0 | 0s | 0s | finalize | Test::Builder::
0 | 0 | 0 | 0s | 0s | is_eq | Test::Builder::
0 | 0 | 0 | 0s | 0s | is_num | Test::Builder::
0 | 0 | 0 | 0s | 0s | isnt_num | Test::Builder::
0 | 0 | 0 | 0s | 0s | like | Test::Builder::
0 | 0 | 0 | 0s | 0s | maybe_regex | Test::Builder::
0 | 0 | 0 | 0s | 0s | name | Test::Builder::
0 | 0 | 0 | 0s | 0s | no_plan | Test::Builder::
0 | 0 | 0 | 0s | 0s | note | Test::Builder::
0 | 0 | 0 | 0s | 0s | parent | Test::Builder::
0 | 0 | 0 | 0s | 0s | skip | Test::Builder::
0 | 0 | 0 | 0s | 0s | skip_all | Test::Builder::
0 | 0 | 0 | 0s | 0s | subtest | Test::Builder::
0 | 0 | 0 | 0s | 0s | summary | Test::Builder::
0 | 0 | 0 | 0s | 0s | todo_end | Test::Builder::
0 | 0 | 0 | 0s | 0s | todo_skip | Test::Builder::
0 | 0 | 0 | 0s | 0s | todo_start | Test::Builder::
0 | 0 | 0 | 0s | 0s | unlike | Test::Builder::
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 # 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 # 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 # 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 | ||||
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 | ||||
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 # 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 | 1 | 49µ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 | 24 | 367µ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 | ||
67 | 22 | 321µs | *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 | ||||
122 | 7 | 52µs | my($class) = shift; | ||
123 | 7 | 19µs | 1 | 2.39ms | $Test ||= $class->create; # spent 2.39ms making 1 call to Test::Builder::create |
124 | 7 | 207µs | 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 | ||||
142 | 1 | 3µs | my $class = shift; | ||
143 | |||||
144 | 1 | 23µs | my $self = bless {}, $class; | ||
145 | 1 | 8µs | 1 | 2.35ms | $self->reset; # spent 2.35ms making 1 call to Test::Builder::reset |
146 | |||||
147 | 1 | 18µs | return $self; | ||
148 | } | ||||
149 | |||||
150 | =item B<child> | ||||
151 | |||||
152 | my $child = $builder->child($name_of_child); | ||||
153 | $child->plan( tests => 4 ); | ||||
154 | $child->ok(some_code()); | ||||
155 | ... | ||||
156 | $child->finalize; | ||||
157 | |||||
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 | ||||
341 | 22 | 46µs | my $self = shift; | ||
342 | |||||
343 | 22 | 40µs | if( @_ ) { | ||
344 | $self->{Indent} = shift; | ||||
345 | } | ||||
346 | |||||
347 | 22 | 432µs | 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 | ||||
400 | 1 | 3µ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 | 1 | 2µs | $Level = 1; | ||
405 | |||||
406 | 1 | 9µs | $self->{Name} = $0; | ||
407 | 1 | 7µs | 1 | 15µs | $self->is_passing(1); # spent 15µs making 1 call to Test::Builder::is_passing |
408 | 1 | 2µs | $self->{Ending} = 0; | ||
409 | 1 | 2µs | $self->{Have_Plan} = 0; | ||
410 | 1 | 2µs | $self->{No_Plan} = 0; | ||
411 | 1 | 2µs | $self->{Have_Output_Plan} = 0; | ||
412 | 1 | 2µs | $self->{Done_Testing} = 0; | ||
413 | |||||
414 | 1 | 2µs | $self->{Original_Pid} = $$; | ||
415 | 1 | 5µs | $self->{Child_Name} = undef; | ||
416 | 1 | 4µs | $self->{Indent} ||= ''; | ||
417 | |||||
418 | 1 | 13µs | 1 | 7µs | share( $self->{Curr_Test} ); # spent 7µs making 1 call to Test::Builder::__ANON__[Test/Builder.pm:66] |
419 | 1 | 3µs | $self->{Curr_Test} = 0; | ||
420 | 1 | 9µs | 1 | 6µs | $self->{Test_Results} = &share( [] ); # spent 6µs making 1 call to Test::Builder::__ANON__[Test/Builder.pm:66] |
421 | |||||
422 | 1 | 2µs | $self->{Exported_To} = undef; | ||
423 | 1 | 2µs | $self->{Expected_Tests} = 0; | ||
424 | |||||
425 | 1 | 2µs | $self->{Skip_All} = 0; | ||
426 | |||||
427 | 1 | 2µs | $self->{Use_Nums} = 1; | ||
428 | |||||
429 | 1 | 5µs | $self->{No_Header} = 0; | ||
430 | 1 | 2µs | $self->{No_Ending} = 0; | ||
431 | |||||
432 | 1 | 2µs | $self->{Todo} = undef; | ||
433 | 1 | 3µs | $self->{Todo_Stack} = []; | ||
434 | 1 | 2µs | $self->{Start_Todo} = 0; | ||
435 | 1 | 2µs | $self->{Opened_Testhandles} = 0; | ||
436 | |||||
437 | 1 | 8µs | 1 | 2.17ms | $self->_dup_stdhandles; # spent 2.17ms making 1 call to Test::Builder::_dup_stdhandles |
438 | |||||
439 | 1 | 13µs | 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 | ||||
483 | 1 | 3µs | my( $self, $cmd, $arg ) = @_; | ||
484 | |||||
485 | 1 | 15µs | 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 | ||||
532 | 1 | 2µs | my $self = shift; | ||
533 | 1 | 3µs | my($max) = @_; | ||
534 | |||||
535 | 1 | 1µs | 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 | 1 | 27µs | 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 | ||||
589 | 1 | 4µs | my($self, $max, $directive, $reason) = @_; | ||
590 | |||||
591 | 1 | 2µs | $self->carp("The plan was already output") if $self->{Have_Output_Plan}; | ||
592 | |||||
593 | 1 | 4µs | my $plan = "1..$max"; | ||
594 | 1 | 1µs | $plan .= " # $directive" if defined $directive; | ||
595 | 1 | 800ns | $plan .= " $reason" if defined $reason; | ||
596 | |||||
597 | 1 | 7µs | 1 | 172µs | $self->_print("$plan\n"); # spent 172µs making 1 call to Test::Builder::_print |
598 | |||||
599 | 1 | 8µs | $self->{Have_Output_Plan} = 1; | ||
600 | |||||
601 | 1 | 23µs | 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 | ||||
641 | 1 | 3µs | my($self, $num_tests) = @_; | ||
642 | |||||
643 | # If done_testing() specified the number of tests, shut off no_plan. | ||||
644 | 1 | 3µs | if( defined $num_tests ) { | ||
645 | $self->{No_Plan} = 0; | ||||
646 | } | ||||
647 | else { | ||||
648 | 1 | 18µs | 1 | 61µs | $num_tests = $self->current_test; # spent 61µs making 1 call to Test::Builder::current_test |
649 | } | ||||
650 | |||||
651 | 1 | 3µs | 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 | 1 | 16µs | $self->{Done_Testing} = [caller]; | ||
658 | |||||
659 | 1 | 16µ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 | 1 | 10µs | $self->{Expected_Tests} = $num_tests; | ||
665 | } | ||||
666 | |||||
667 | 1 | 10µs | 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 | 1 | 8µs | $self->{Have_Plan} = 1; | ||
670 | |||||
671 | # The wrong number of tests were run | ||||
672 | 1 | 4µs | $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test}; | ||
673 | |||||
674 | # No tests were run | ||||
675 | 1 | 2µs | $self->is_passing(0) if $self->{Curr_Test} == 0; | ||
676 | |||||
677 | 1 | 22µs | 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 | ||||
692 | 20 | 26µs | my $self = shift; | ||
693 | |||||
694 | 20 | 53µs | return( $self->{Expected_Tests} ) if $self->{Expected_Tests}; | ||
695 | 20 | 41µs | return('no_plan') if $self->{No_Plan}; | ||
696 | 20 | 210µs | 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 | ||||
734 | 1 | 4µs | my( $self, $pack ) = @_; | ||
735 | |||||
736 | 1 | 6µs | if( defined $pack ) { | ||
737 | $self->{Exported_To} = $pack; | ||||
738 | } | ||||
739 | 1 | 16µs | 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 | ||||
764 | 20 | 192µs | my( $self, $test, $name ) = @_; | ||
765 | |||||
766 | 20 | 89µs | 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 | 20 | 31µs | $test = $test ? 1 : 0; | ||
774 | |||||
775 | 20 | 417µs | 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 | 20 | 44µs | $self->{Curr_Test}++; | ||
777 | |||||
778 | # In case $name is a string overloaded object, force it to stringify. | ||||
779 | 20 | 382µs | 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 | 1.05ms | 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 | 625µs | 20 | 4.07ms | my $todo = $self->todo(); # spent 4.07ms making 20 calls to Test::Builder::todo, avg 203µs/call |
789 | 20 | 203µs | 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 | 20 | 21µs | local $self->{Todo} = $todo if $in_todo; | ||
791 | |||||
792 | 20 | 142µs | 20 | 3.61ms | $self->_unoverload_str( \$todo ); # spent 3.61ms making 20 calls to Test::Builder::_unoverload_str, avg 180µs/call |
793 | |||||
794 | 20 | 15µs | my $out; | ||
795 | 20 | 361µs | 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 | 62µs | unless($test) { | ||
798 | $out .= "not "; | ||||
799 | @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 ); | ||||
800 | } | ||||
801 | else { | ||||
802 | 20 | 329µs | @$result{ 'ok', 'actual_ok' } = ( 1, $test ); | ||
803 | } | ||||
804 | |||||
805 | 20 | 50µs | $out .= "ok"; | ||
806 | 20 | 380µs | 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 | 20 | 56µs | if( defined $name ) { | ||
809 | 20 | 438µs | 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 | 20 | 65µs | $out .= " - $name"; | ||
811 | 20 | 225µs | $result->{name} = $name; | ||
812 | } | ||||
813 | else { | ||||
814 | $result->{name} = ''; | ||||
815 | } | ||||
816 | |||||
817 | 20 | 182µ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 | 20 | 395µs | $result->{reason} = ''; | ||
824 | 20 | 70µs | $result->{type} = ''; | ||
825 | } | ||||
826 | |||||
827 | 20 | 156µs | $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result; | ||
828 | 20 | 28µs | $out .= "\n"; | ||
829 | |||||
830 | 20 | 375µs | 20 | 6.92ms | $self->_print($out); # spent 6.92ms making 20 calls to Test::Builder::_print, avg 346µs/call |
831 | |||||
832 | 20 | 24µs | 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 | 20 | 17µs | $self->is_passing(0) unless $test || $self->in_todo; | ||
847 | |||||
848 | # Check that we haven't violated the plan | ||||
849 | 20 | 299µs | 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 | 20 | 259µs | 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 | ||||
858 | 20 | 32µs | my $self = shift; | ||
859 | |||||
860 | 20 | 159µs | 20 | 241µs | my $plan = $self->has_plan; # spent 241µs making 20 calls to Test::Builder::has_plan, avg 12µs/call |
861 | 20 | 244µs | 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 | ||||
868 | 40 | 51µs | my $self = shift; | ||
869 | 40 | 76µs | my $type = shift; | ||
870 | |||||
871 | 80 | 2.23ms | 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 # spent 3.71ms making 40 calls to Test::Builder::_try, avg 93µs/call |
872 | |||||
873 | 40 | 160µs | 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 | 40 | 310µs | 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 | ||||
885 | 40 | 162µs | my( $self, $thing ) = @_; | ||
886 | |||||
887 | 80 | 1.60ms | 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 # spent 1.95ms making 40 calls to Test::Builder::_try, avg 49µs/call |
888 | } | ||||
889 | |||||
890 | sub _unoverload_str { | ||||
891 | 40 | 56µs | my $self = shift; | ||
892 | |||||
893 | 40 | 666µs | 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 # 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 | ||||
1035 | 2 | 13µs | my( $self, $got, $dont_expect, $name ) = @_; | ||
1036 | 2 | 26µs | local $Level = $Level + 1; | ||
1037 | |||||
1038 | 2 | 6µs | 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 | 90µs | 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 | ||||
1110 | 2 | 41µs | my( $self, $got, $type, $expect, $name ) = @_; | ||
1111 | |||||
1112 | 2 | 2µs | my $test; | ||
1113 | 2 | 1µs | my $error; | ||
1114 | { | ||||
1115 | ## no critic (BuiltinFunctions::ProhibitStringyEval) | ||||
1116 | |||||
1117 | 4 | 131µs | local( $@, $!, $SIG{__DIE__} ); # isolate eval | ||
1118 | |||||
1119 | 2 | 60µs | 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 | 2 | 452µs | $test = eval qq[ | ||
1123 | #line $line "(eval in cmp_ok) $file" | ||||
1124 | \$got $type \$expect; | ||||
1125 | ]; | ||||
1126 | 2 | 26µs | $error = $@; | ||
1127 | } | ||||
1128 | 2 | 6µs | local $Level = $Level + 1; | ||
1129 | 2 | 61µs | 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 | 2 | 22µs | my $unoverload | ||
1134 | = $numeric_cmps{$type} | ||||
1135 | ? '_unoverload_num' | ||||
1136 | : '_unoverload_str'; | ||||
1137 | |||||
1138 | 2 | 2µs | $self->diag(<<"END") if $error; | ||
1139 | An error occurred while using $type: | ||||
1140 | ------------------------------------ | ||||
1141 | $error | ||||
1142 | ------------------------------------ | ||||
1143 | END | ||||
1144 | |||||
1145 | 2 | 2µs | 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 | 2 | 36µs | 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 # 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 | ||||
1452 | 82 | 531µs | my( $self, $code, %opts ) = @_; | ||
1453 | |||||
1454 | 82 | 46µs | my $error; | ||
1455 | 82 | 42µs | my $return; | ||
1456 | { | ||||
1457 | 164 | 901µs | local $!; # eval can mess up $! | ||
1458 | 82 | 61µs | local $@; # don't set $@ in the test | ||
1459 | 82 | 461µs | local $SIG{__DIE__}; # don't trip an outside DIE handler. | ||
1460 | 164 | 917µ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 | 82 | 660µs | $error = $@; | ||
1462 | } | ||||
1463 | |||||
1464 | 82 | 67µs | die $error if $error and $opts{die_on_fail}; | ||
1465 | |||||
1466 | 82 | 1.01ms | 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 | ||||
1481 | 3 | 3µs | my $self = shift; | ||
1482 | 3 | 2µs | my $maybe_fh = shift; | ||
1483 | 3 | 3µs | return 0 unless defined $maybe_fh; | ||
1484 | |||||
1485 | 3 | 35µs | 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 | ||||
1524 | 63 | 131µs | my( $self, $level ) = @_; | ||
1525 | |||||
1526 | 63 | 57µs | if( defined $level ) { | ||
1527 | $Level = $level; | ||||
1528 | } | ||||
1529 | 63 | 758µs | 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 | ||||
1556 | 20 | 59µs | my( $self, $use_nums ) = @_; | ||
1557 | |||||
1558 | 20 | 20µs | if( defined $use_nums ) { | ||
1559 | $self->{Use_Nums} = $use_nums; | ||||
1560 | } | ||||
1561 | 20 | 255µs | 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 | 3 | 7µs | my $method = lc $attribute; | ||
1590 | |||||
1591 | my $code = sub { | ||||
1592 | 2 | 7µs | my( $self, $no ) = @_; | ||
1593 | |||||
1594 | 2 | 2µs | if( defined $no ) { | ||
1595 | $self->{$attribute} = $no; | ||||
1596 | } | ||||
1597 | 2 | 61µs | return $self->{$attribute}; | ||
1598 | 3 | 26µs | }; | ||
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 # spent 113µs making 1 call to Test::Builder::BEGIN@1600
# spent 71µs making 1 call to strict::unimport |
1601 | 3 | 38µs | *{ __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 | ||||
1642 | 1 | 2µs | my $self = shift; | ||
1643 | |||||
1644 | 1 | 43µs | 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 | ||||
1663 | 1 | 2µs | my $self = shift; | ||
1664 | |||||
1665 | 1 | 3µs | local $Level = $Level + 1; | ||
1666 | 1 | 57µs | 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 | ||||
1670 | 1 | 7µs | my( $self, $fh, @msgs ) = @_; | ||
1671 | |||||
1672 | 1 | 19µs | 1 | 24µs | return if $self->no_diag; # spent 24µs making 1 call to Test::Builder::__ANON__[Test/Builder.pm:1598] |
1673 | 1 | 2µs | return unless @msgs; | ||
1674 | |||||
1675 | # Prevent printing headers when compiling (i.e. -c) | ||||
1676 | 1 | 3µs | return if $^C; | ||
1677 | |||||
1678 | # Smash args together like print does. | ||||
1679 | # Convert undef to 'undef' so its readable. | ||||
1680 | 1 | 15µs | my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs; | ||
1681 | |||||
1682 | # Escape the beginning, _print will take care of the rest. | ||||
1683 | 1 | 40µs | 1 | 23µs | $msg =~ s/^/# /; # spent 23µs making 1 call to Test::Builder::CORE:subst |
1684 | |||||
1685 | 1 | 3µs | local $Level = $Level + 1; | ||
1686 | 1 | 9µs | 1 | 200µs | $self->_print_to_fh( $fh, $msg ); # spent 200µs making 1 call to Test::Builder::_print_to_fh |
1687 | |||||
1688 | 1 | 28µs | 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 | sub _print { | ||||
1736 | 21 | 39µs | my $self = shift; | ||
1737 | 21 | 1.03ms | 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 | sub _print_to_fh { | ||||
1741 | 22 | 136µs | my( $self, $fh, @msgs ) = @_; | ||
1742 | |||||
1743 | # Prevent printing headers when only compiling. Mostly for when | ||||
1744 | # tests are deparsed with B::Deparse | ||||
1745 | 22 | 175µs | return if $^C; | ||
1746 | |||||
1747 | 22 | 127µs | my $msg = join '', @msgs; | ||
1748 | 22 | 432µs | 22 | 623µs | my $indent = $self->_indent; # spent 623µs making 22 calls to Test::Builder::_indent, avg 28µs/call |
1749 | |||||
1750 | 22 | 462µs | local( $\, $", $, ) = ( undef, ' ', '' ); | ||
1751 | |||||
1752 | # Escape each line after the first with a # so we don't | ||||
1753 | # confuse Test::Harness. | ||||
1754 | 22 | 736µs | 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 | 477µs | 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.62ms | 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 | sub output { | ||||
1796 | 22 | 74µs | my( $self, $fh ) = @_; | ||
1797 | |||||
1798 | 22 | 31µs | 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 | 22 | 310µs | return $self->{Out_FH}; | ||
1802 | } | ||||
1803 | |||||
1804 | sub failure_output { | ||||
1805 | 2 | 7µs | my( $self, $fh ) = @_; | ||
1806 | |||||
1807 | 2 | 9µs | 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 | 2 | 47µs | 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 | ||||
1814 | 1 | 3µs | my( $self, $fh ) = @_; | ||
1815 | |||||
1816 | 1 | 7µs | 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 | 1 | 20µs | return $self->{Todo_FH}; | ||
1820 | } | ||||
1821 | |||||
1822 | sub _new_fh { | ||||
1823 | 3 | 3µs | my $self = shift; | ||
1824 | 3 | 4µs | my($file_or_fh) = shift; | ||
1825 | |||||
1826 | 3 | 2µs | my $fh; | ||
1827 | 3 | 18µs | 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 | 3 | 34µs | 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 | ||||
1852 | 4 | 8µs | my($fh) = shift; | ||
1853 | 4 | 57µs | 4 | 20µs | my $old_fh = select $fh; # spent 20µs making 4 calls to Test::Builder::CORE:select, avg 5µs/call |
1854 | 4 | 9µs | $| = 1; | ||
1855 | 4 | 41µs | 4 | 10µs | select $old_fh; # spent 10µs making 4 calls to Test::Builder::CORE:select, avg 3µs/call |
1856 | |||||
1857 | 4 | 43µs | 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 | ||||
1863 | 1 | 2µs | my $self = shift; | ||
1864 | |||||
1865 | 1 | 7µs | 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 | 7µs | 1 | 59µs | _autoflush($Testout); # spent 59µs making 1 call to Test::Builder::_autoflush |
1870 | 1 | 6µs | 1 | 26µs | _autoflush( \*STDOUT ); # spent 26µs making 1 call to Test::Builder::_autoflush |
1871 | 1 | 5µs | 1 | 25µs | _autoflush($Testerr); # spent 25µs making 1 call to Test::Builder::_autoflush |
1872 | 1 | 5µs | 1 | 24µs | _autoflush( \*STDERR ); # spent 24µs making 1 call to Test::Builder::_autoflush |
1873 | |||||
1874 | 1 | 7µs | 1 | 209µs | $self->reset_outputs; # spent 209µs making 1 call to Test::Builder::reset_outputs |
1875 | |||||
1876 | 1 | 14µs | 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 | ||||
1880 | 1 | 2µs | my $self = shift; | ||
1881 | |||||
1882 | 1 | 2µs | 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 | 138µs | 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 | 47µs | 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 | 10µs | 1 | 1.34ms | $self->_copy_io_layers( \*STDOUT, $Testout ); # spent 1.34ms making 1 call to Test::Builder::_copy_io_layers |
1890 | 1 | 10µs | 1 | 177µs | $self->_copy_io_layers( \*STDERR, $Testerr ); # spent 177µs making 1 call to Test::Builder::_copy_io_layers |
1891 | |||||
1892 | 1 | 4µs | $self->{Opened_Testhandles} = 1; | ||
1893 | |||||
1894 | 1 | 13µs | return; | ||
1895 | } | ||||
1896 | |||||
1897 | sub _copy_io_layers { | ||||
1898 | 2 | 6µ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 | ||||
1902 | 2 | 967µs | require PerlIO; | ||
1903 | 2 | 84µs | 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 | 38µs | 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 | 58µs | 2 | 1.43ms | ); # spent 1.43ms making 2 calls to Test::Builder::_try, avg 714µs/call |
1908 | |||||
1909 | 2 | 25µs | 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 | ||||
1913 | 2 | 10µs | my ($fh, @layers) = @_; | ||
1914 | 2 | 2µs | my %seen; | ||
1915 | 2 | 23µs | my @unique = grep { $_ ne 'unix' and !$seen{$_}++ } @layers; | ||
1916 | 2 | 120µs | 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 | ||||
1929 | 1 | 2µs | my $self = shift; | ||
1930 | |||||
1931 | 1 | 7µs | 1 | 63µs | $self->output ($Testout); # spent 63µs making 1 call to Test::Builder::output |
1932 | 1 | 7µs | 1 | 47µs | $self->failure_output($Testerr); # spent 47µs making 1 call to Test::Builder::failure_output |
1933 | 1 | 6µs | 1 | 44µs | $self->todo_output ($Testout); # spent 44µs making 1 call to Test::Builder::todo_output |
1934 | |||||
1935 | 1 | 12µs | 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 | ||||
1995 | 1 | 3µs | my( $self, $num ) = @_; | ||
1996 | |||||
1997 | 1 | 9µs | 1 | 7µs | lock( $self->{Curr_Test} ); # spent 7µs making 1 call to Test::Builder::__ANON__[Test/Builder.pm:67] |
1998 | 1 | 1µs | 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 | 1 | 34µs | 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 | ||||
2043 | 1 | 2µs | my $self = shift; | ||
2044 | |||||
2045 | 1 | 4µs | if( @_ ) { | ||
2046 | $self->{Is_Passing} = shift; | ||||
2047 | } | ||||
2048 | |||||
2049 | 1 | 30µs | 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 | ||||
2149 | 20 | 71µs | my( $self, $pack ) = @_; | ||
2150 | |||||
2151 | 20 | 60µs | return $self->{Todo} if defined $self->{Todo}; | ||
2152 | |||||
2153 | 20 | 223µs | local $Level = $Level + 1; | ||
2154 | 20 | 288µs | 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 | 20 | 19µs | return $todo if defined $todo; | ||
2156 | |||||
2157 | 20 | 193µs | 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 | sub find_TODO { | ||||
2176 | 61 | 185µs | my( $self, $pack, $set, $new_value ) = @_; | ||
2177 | |||||
2178 | 61 | 684µs | 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 | 61 | 37µs | 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 # spent 120µs making 1 call to Test::Builder::BEGIN@2181
# spent 72µs making 1 call to strict::unimport |
2182 | 61 | 499µs | my $old_value = ${ $pack . '::TODO' }; | ||
2183 | 61 | 45µs | $set and ${ $pack . '::TODO' } = $new_value; | ||
2184 | 61 | 518µs | 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 | ||||
2196 | 41 | 55µs | my $self = shift; | ||
2197 | |||||
2198 | 41 | 144µs | local $Level = $Level + 1; | ||
2199 | 41 | 593µs | 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 | sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms) | ||||
2301 | 63 | 132µs | my( $self, $height ) = @_; | ||
2302 | 63 | 43µs | $height ||= 0; | ||
2303 | |||||
2304 | 63 | 884µs | 63 | 728µs | my $level = $self->level + $height + 1; # spent 728µs making 63 calls to Test::Builder::level, avg 12µs/call |
2305 | 63 | 56µs | my @caller; | ||
2306 | 63 | 239µs | do { | ||
2307 | 63 | 1.52ms | @caller = CORE::caller( $level ); | ||
2308 | 63 | 84µs | $level--; | ||
2309 | } until @caller; | ||||
2310 | 63 | 821µs | 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 | ||||
2377 | 1 | 3µs | $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars) | ||
2378 | |||||
2379 | 1 | 27µs | 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 | ||||
2389 | 1 | 2µs | my $self = shift; | ||
2390 | 1 | 16µs | 1 | 21µs | return if $self->no_ending; # spent 21µs making 1 call to Test::Builder::__ANON__[Test/Builder.pm:1598] |
2391 | 1 | 3µs | return if $self->{Ending}++; | ||
2392 | |||||
2393 | 1 | 12µs | 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 | 1 | 3µs | if( $self->{Original_Pid} != $$ ) { | ||
2398 | return; | ||||
2399 | } | ||||
2400 | |||||
2401 | # Ran tests but never declared a plan or hit done_testing | ||||
2402 | 1 | 2µs | 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 | 1 | 1µs | if( !$self->{Have_Plan} ) { | ||
2410 | return; | ||||
2411 | } | ||||
2412 | |||||
2413 | # Don't do an ending if we bailed out. | ||||
2414 | 1 | 2µs | 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 | 1 | 2µs | my $test_results = $self->{Test_Results}; | ||
2420 | 1 | 2µs | if(@$test_results) { | ||
2421 | # The plan? We have no plan. | ||||
2422 | 1 | 2µs | 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 | 11µs | 1 | 9µs | my $empty_result = &share( {} ); # spent 9µs making 1 call to Test::Builder::__ANON__[Test/Builder.pm:66] |
2431 | 1 | 25µs | 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 | 1 | 52µs | my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ]; | ||
2437 | |||||
2438 | 1 | 3µs | my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; | ||
2439 | |||||
2440 | 1 | 2µs | 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 | 1 | 900ns | 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 | 1 | 1µs | 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 | 1 | 1µs | my $exit_code; | ||
2469 | 1 | 3µ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 | 1 | 2µs | $exit_code = 0; | ||
2477 | } | ||||
2478 | |||||
2479 | 1 | 39µs | 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 | ||||
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:match; # opcode | |||||
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: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 |