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