File Coverage

inc/Test/Builder.pm
Criterion Covered Total %
statement 159 352 45.2
branch 49 192 25.5
condition 11 50 22.0
subroutine 32 51 62.7
pod 31 32 96.9
total 282 677 41.7


line stmt bran cond sub pod time code
1             #line 1
2             package Test::Builder;
3 8     8   154  
  8         74  
  8         76  
4             use 5.004;
5              
6             # $^C was only introduced in 5.005-ish. We do this to prevent
7             # use of uninitialized value warnings in older perls.
8             $^C ||= 0;
9 8     8   115  
  8         70  
  8         109  
10 8     8   120 use strict;
  8         76  
  8         109  
11             use vars qw($VERSION $CLASS);
12             $VERSION = '0.17';
13             $CLASS = __PACKAGE__;
14              
15             my $IsVMS = $^O eq 'VMS';
16              
17             # Make Test::Builder thread-safe for ithreads.
18 8     8   257 BEGIN {
  8         73  
  8         113  
19 8 50 33 8   103     use Config;
20 0         0     if( $] >= 5.008 && $Config{useithreads} ) {
21 0         0         require threads;
22 0         0         require threads::shared;
23                     threads::shared->import;
24                 }
25 8     147   139     else {
  147         1390  
26 8     115   91         *share = sub { 0 };
  115         1205  
27                     *lock = sub { 0 };
28                 }
29             }
30 8     8   119  
  8         70  
  8         135  
31             use vars qw($Level);
32             my($Test_Died) = 0;
33             my($Have_Plan) = 0;
34             my $Original_Pid = $$;
35             my $Curr_Test = 0; share($Curr_Test);
36             my @Test_Results = (); share(@Test_Results);
37             my @Test_Details = (); share(@Test_Details);
38              
39              
40             #line 93
41              
42             my $Test;
43             sub new {
44                 my($class) = shift;
45                 $Test ||= bless ['Move along, nothing to see here'], $class;
46                 return $Test;
47             }
48              
49             #line 119
50              
51             my $Exported_To;
52             sub exported_to {
53                 my($self, $pack) = @_;
54              
55                 if( defined $pack ) {
56                     $Exported_To = $pack;
57                 }
58                 return $Exported_To;
59             }
60              
61             #line 142
62              
63             sub plan {
64                 my($self, $cmd, $arg) = @_;
65              
66                 return unless $cmd;
67              
68                 if( $Have_Plan ) {
69                     die sprintf "You tried to plan twice! Second plan at %s line %d\n",
70                       ($self->caller)[1,2];
71                 }
72              
73                 if( $cmd eq 'no_plan' ) {
74                     $self->no_plan;
75                 }
76                 elsif( $cmd eq 'skip_all' ) {
77                     return $self->skip_all($arg);
78                 }
79                 elsif( $cmd eq 'tests' ) {
80                     if( $arg ) {
81                         return $self->expected_tests($arg);
82                     }
83                     elsif( !defined $arg ) {
84                         die "Got an undefined number of tests. Looks like you tried to ".
85                             "say how many tests you plan to run but made a mistake.\n";
86                     }
87                     elsif( !$arg ) {
88                         die "You said to run 0 tests! You've got to run something.\n";
89                     }
90                 }
91                 else {
92                     require Carp;
93                     my @args = grep { defined } ($cmd, $arg);
94                     Carp::croak("plan() doesn't understand @args");
95                 }
96 8     8 1 88  
97 8   50     137     return 1;
98 8         102 }
99              
100             #line 189
101              
102             my $Expected_Tests = 0;
103             sub expected_tests {
104                 my($self, $max) = @_;
105              
106                 if( defined $max ) {
107                     $Expected_Tests = $max;
108                     $Have_Plan = 1;
109              
110                     $self->_print("1..$max\n") unless $self->no_header;
111                 }
112                 return $Expected_Tests;
113             }
114              
115              
116             #line 211
117              
118             my($No_Plan) = 0;
119             sub no_plan {
120                 $No_Plan = 1;
121                 $Have_Plan = 1;
122 8     8 1 86 }
123              
124 8 50       101 #line 225
125 8         79  
126             sub has_plan {
127 8         85 return($Expected_Tests) if $Expected_Tests;
128             return('no_plan') if $No_Plan;
129             return(undef);
130             };
131              
132              
133             #line 241
134              
135             my $Skip_All = 0;
136             sub skip_all {
137                 my($self, $reason) = @_;
138              
139                 my $out = "1..0";
140                 $out .= " # Skip $reason" if $reason;
141                 $out .= "\n";
142              
143                 $Skip_All = 1;
144 8     8 1 87  
145                 $self->_print($out) unless $self->no_header;
146 8 50       96     exit(0);
147             }
148 8 50       88  
149 0         0 #line 275
150              
151             sub ok {
152                 my($self, $test, $name) = @_;
153 8 50       327  
    50          
    50          
154 0         0 # $test might contain an object which we don't want to accidentally
155             # store, so we turn it into a boolean.
156                 $test = $test ? 1 : 0;
157 0         0  
158                 unless( $Have_Plan ) {
159                     require Carp;
160 8 50       93         Carp::croak("You tried to run a test without a plan! Gotta have a plan.");
    0          
    0          
161 8         95     }
162              
163                 lock $Curr_Test;
164 0         0     $Curr_Test++;
165              
166                 $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
167             You named your test '$name'. You shouldn't use numbers for your test names.
168 0         0 Very confusing.
169             ERR
170              
171                 my($pack, $file, $line) = $self->caller;
172 0         0  
173 0         0     my $todo = $self->todo($pack);
  0         0  
174 0         0  
175                 my $out;
176                 my $result = {};
177 0         0     share($result);
178              
179                 unless( $test ) {
180                     $out .= "not ";
181                     @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
182                 }
183                 else {
184                     @$result{ 'ok', 'actual_ok' } = ( 1, $test );
185                 }
186              
187                 $out .= "ok";
188                 $out .= " $Curr_Test" if $self->use_numbers;
189              
190                 if( defined $name ) {
191                     $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
192 8     8 1 83         $out .= " - $name";
193                     $result->{name} = $name;
194 8 50       127     }
195 8         76     else {
196 8         76         $result->{name} = '';
197                 }
198 8 50       93  
199                 if( $todo ) {
200 8         102         my $what_todo = $todo;
201                     $out .= " # TODO $what_todo";
202                     $result->{reason} = $what_todo;
203                     $result->{type} = 'todo';
204                 }
205                 else {
206                     $result->{reason} = '';
207                     $result->{type} = '';
208                 }
209              
210                 $Test_Results[$Curr_Test-1] = $result;
211                 $out .= "\n";
212              
213                 $self->_print($out);
214 0     0 1 0  
215 0         0     unless( $test ) {
216                     my $msg = $todo ? "Failed (TODO)" : "Failed";
217                     $self->diag(" $msg test ($file at line $line)\n");
218                 }
219              
220                 return $test ? 1 : 0;
221             }
222              
223             #line 363
224              
225             sub is_eq {
226                 my($self, $got, $expect, $name) = @_;
227 0 0   0 1 0     local $Level = $Level + 1;
228 0 0       0  
229 0         0     if( !defined $got || !defined $expect ) {
230             # undef only matches undef and nothing else
231                     my $test = !defined $got && !defined $expect;
232              
233                     $self->ok($test, $name);
234                     $self->_is_diag($got, 'eq', $expect) unless $test;
235                     return $test;
236                 }
237              
238                 return $self->cmp_ok($got, 'eq', $expect, $name);
239             }
240              
241             sub is_num {
242                 my($self, $got, $expect, $name) = @_;
243                 local $Level = $Level + 1;
244 0     0 1 0  
245                 if( !defined $got || !defined $expect ) {
246 0         0 # undef only matches undef and nothing else
247 0 0       0         my $test = !defined $got && !defined $expect;
248 0         0  
249                     $self->ok($test, $name);
250 0         0         $self->_is_diag($got, '==', $expect) unless $test;
251                     return $test;
252 0 0       0     }
253 0         0  
254                 return $self->cmp_ok($got, '==', $expect, $name);
255             }
256              
257             sub _is_diag {
258                 my($self, $got, $type, $expect) = @_;
259              
260                 foreach my $val (\$got, \$expect) {
261                     if( defined $$val ) {
262                         if( $type eq 'eq' ) {
263             # quote and force string context
264                             $$val = "'$$val'"
265                         }
266                         else {
267             # force numeric context
268                             $$val = $$val+0;
269                         }
270                     }
271                     else {
272                         $$val = 'undef';
273                     }
274                 }
275              
276                 return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
277 115     115 1 1423 got: %s
278             expected: %s
279             DIAGNOSTIC
280              
281 115 50       1129 }    
282              
283 115 50       1427 #line 437
284 0         0  
285 0         0 sub isnt_eq {
286                 my($self, $got, $dont_expect, $name) = @_;
287                 local $Level = $Level + 1;
288 115         3302  
289 115         957     if( !defined $got || !defined $dont_expect ) {
290             # undef only matches undef and nothing else
291 115 50 33     1928         my $test = defined $got || defined $dont_expect;
292              
293                     $self->ok($test, $name);
294                     $self->_cmp_diag('ne', $got, $dont_expect) unless $test;
295                     return $test;
296 115         1214     }
297              
298 115         1556     return $self->cmp_ok($got, 'ne', $dont_expect, $name);
299             }
300 115         992  
301 115         1232 sub isnt_num {
302 115         1322     my($self, $got, $dont_expect, $name) = @_;
303                 local $Level = $Level + 1;
304 115 50       3944  
305 0         0     if( !defined $got || !defined $dont_expect ) {
306 0 0       0 # undef only matches undef and nothing else
307                     my $test = defined $got || defined $dont_expect;
308              
309 115         1775         $self->ok($test, $name);
310                     $self->_cmp_diag('!=', $got, $dont_expect) unless $test;
311                     return $test;
312 115         1058     }
313 115 50       1161  
314                 return $self->cmp_ok($got, '!=', $dont_expect, $name);
315 115 50       1342 }
316 115         1066  
317 115         1047  
318 115         1319 #line 489
319              
320             sub like {
321 0         0     my($self, $this, $regex, $name) = @_;
322              
323                 local $Level = $Level + 1;
324 115 50       1223     $self->_regex_ok($this, $regex, '=~', $name);
325 0         0 }
326 0         0  
327 0         0 sub unlike {
328 0         0     my($self, $this, $regex, $name) = @_;
329              
330                 local $Level = $Level + 1;
331 115         1126     $self->_regex_ok($this, $regex, '!~', $name);
332 115         1261 }
333              
334             #line 530
335 115         1424  
336 115         1040  
337             sub maybe_regex {
338 115         1188 my ($self, $regex) = @_;
339               &nb