File Coverage

support/Test/Builder.pm
Criterion Covered Total %
statement 253 472 53.6
branch 72 254 28.3
condition 21 79 26.6
subroutine 44 63 69.8
pod 32 32 100.0
total 422 900 46.9


line stmt bran cond sub pod time code
1             package Test::Builder;
2              
3 11     11   254 use 5.004;
  11         101  
  11         99  
4              
5             # $^C was only introduced in 5.005-ish. We do this to prevent
6             # use of uninitialized value warnings in older perls.
7             $^C ||= 0;
8              
9 11     11   216 use strict;
  11         98  
  11         162  
10 11     11   209 use vars qw($VERSION);
  11         178  
  11         208  
11             $VERSION = '0.33';
12             $VERSION = eval $VERSION; # make the alpha version come out as a number
13              
14             # Make Test::Builder thread-safe for ithreads.
15             BEGIN {
16 11     11   389     use Config;
  11         99  
  11         156  
17             # Load threads::shared when threads are turned on
18 11 50 33 11   146     if( $] >= 5.008 && $Config{useithreads} && $INC{'threads.pm'}) {
      33        
19 0         0         require threads::shared;
20              
21             # Hack around YET ANOTHER threads::shared bug. It would
22             # occassionally forget the contents of the variable when sharing it.
23             # So we first copy the data, then share, then put our copy back.
24                     *share = sub (\[$@%]) {
25 0         0             my $type = ref $_[0];
26 0         0             my $data;
27              
28 0 0       0             if( $type eq 'HASH' ) {
    0          
    0          
29 0         0                 %$data = %{$_[0]};
  0         0  
30                         }
31                         elsif( $type eq 'ARRAY' ) {
32 0         0                 @$data = @{$_[0]};
  0         0  
33                         }
34                         elsif( $type eq 'SCALAR' ) {
35 0         0                 $$data = ${$_[0]};
  0         0  
36                         }
37                         else {
38 0         0                 die "Unknown type: ".$type;
39                         }
40              
41 0         0             $_[0] = &threads::shared::share($_[0]);
42              
43 0 0       0             if( $type eq 'HASH' ) {
    0          
    0          
44 0         0                 %{$_[0]} = %$data;
  0         0  
45                         }
46                         elsif( $type eq 'ARRAY' ) {
47 0         0                 @{$_[0]} = @$data;
  0         0  
48                         }
49                         elsif( $type eq 'SCALAR' ) {
50 0         0                 ${$_[0]} = $$data;
  0         0  
51                         }
52                         else {
53 0         0                 die "Unknown type: ".$type;
54                         }
55              
56 0         0             return $_[0];
57 0         0         };
58                 }
59             # 5.8.0's threads::shared is busted when threads are off.
60             # We emulate it here.
61                 else {
62 11     2190   259         *share = sub { return $_[0] };
  2190         50668  
63 11     2157   161         *lock = sub { 0 };
  2157         68069  
64                 }
65             }
66              
67              
68             =head1 NAME
69            
70             Test::Builder - Backend for building test libraries
71            
72             =head1 SYNOPSIS
73            
74             package My::Test::Module;
75             use Test::Builder;
76             require Exporter;
77             @ISA = qw(Exporter);
78             @EXPORT = qw(ok);
79            
80             my $Test = Test::Builder->new;
81             $Test->output('my_logfile');
82            
83             sub import {
84             my($self) = shift;
85             my $pack = caller;
86            
87             $Test->exported_to($pack);
88             $Test->plan(@_);
89            
90             $self->export_to_level(1, $self, 'ok');
91             }
92            
93             sub ok {
94             my($test, $name) = @_;
95            
96             $Test->ok($test, $name);
97             }
98            
99            
100             =head1 DESCRIPTION
101            
102             Test::Simple and Test::More have proven to be popular testing modules,
103             but they're not always flexible enough. Test::Builder provides the a
104             building block upon which to write your own test libraries I<which can
105             work together>.
106            
107             =head2 Construction
108            
109             =over 4
110            
111             =item B<new>
112            
113             my $Test = Test::Builder->new;
114            
115             Returns a Test::Builder object representing the current state of the
116             test.
117            
118             Since you only run one test per program C<new> always returns the same
119             Test::Builder object. No matter how many times you call new(), you're
120             getting the same object. This is called a singleton. This is done so that
121             multiple modules share such global information as the test counter and
122             where test output is going.
123            
124             If you want a completely new Test::Builder object different from the
125             singleton, use C<create>.
126            
127             =cut
128              
129             my $Test = Test::Builder->new;
130             sub new {
131 14953     14953 1 206835     my($class) = shift;
132 14953   100     200387     $Test ||= $class->create;
133 14953         217079     return $Test;
134             }
135              
136              
137             =item B<create>
138            
139             my $Test = Test::Builder->create;
140            
141             Ok, so there can be more than one Test::Builder object and this is how
142             you get it. You might use this instead of C<new()> if you're testing
143             a Test::Builder based module, but otherwise you probably want C<new>.
144            
145             B<NOTE>: the implementation is not complete. C<level>, for example, is
146             still shared amongst B<all> Test::Builder objects, even ones created using
147             this method. Also, the method name may change in the future.
148            
149             =cut
150              
151             sub create {
152 11     11 1 110     my $class = shift;
153              
154 11         149     my $self = bless {}, $class;
155 11         135     $self->reset;
156              
157 11         107     return $self;
158             }
159              
160             =item B<reset>
161            
162             $Test->reset;
163            
164             Reinitializes the Test::Builder singleton to its original state.
165             Mostly useful for tests run in persistent environments where the same
166             test might be run multiple times in the same process.
167            
168             =cut
169              
170 11     11   184 use vars qw($Level);
  11         106  
  11         201  
171              
172             sub reset {
173 11     11 1 113     my ($self) = @_;
174              
175             # We leave this a global because it has to be localized and localizing
176             # hash keys is just asking for pain. Also, it was documented.
177 11         163     $Level = 1;
178              
179 11         135     $self->{Test_Died} = 0;
180 11         110     $self->{Have_Plan} = 0;
181 11         108     $self->{No_Plan} = 0;
182 11         109     $self->{Original_Pid} = $$;
183              
184 11         143     share($self->{Curr_Test});
185 11         1800     $self->{Curr_Test} = 0;
186 11         173     $self->{Test_Results} = &share([]);
187              
188 11         114     $self->{Exported_To} = undef;
189 11         117     $self->{Expected_Tests} = 0;
190              
191 11         109     $self->{Skip_All} = 0;
192              
193 11         109     $self->{Use_Nums} = 1;
194              
195 11         106     $self->{No_Header} = 0;
196 11         104     $self->{No_Ending} = 0;
197              
198 11 50       548     $self->_dup_stdhandles unless $^C;
199              
200 11         108     return undef;
201             }
202              
203             =back
204            
205             =head2 Setting up tests
206            
207             These methods are for setting up tests and declaring how many there
208             are. You usually only want to call one of these methods.
209            
210             =over 4
211            
212             =item B<exported_to>
213            
214             my $pack = $Test->exported_to;
215             $Test->exported_to($pack);
216            
217             Tells Test::Builder what package you exported your functions to.
218             This is important for getting TODO tests right.
219            
220             =cut
221              
222             sub exported_to {
223 22     22 1 221     my($self, $pack) = @_;
224              
225 22 50       252     if( defined $pack ) {
226 22         307         $self->{Exported_To} = $pack;
227                 }
228 22         243     return $self->{Exported_To};
229             }
230              
231             =item B<plan>
232            
233             $Test->plan('no_plan');
234             $Test->plan( skip_all => $reason );
235             $Test->plan( tests => $num_tests );
236            
237             A convenient way to set up your tests. Call this and Test::Builder
238             will print the appropriate headers and take the appropriate actions.
239            
240             If you call plan(), don't call any of the other methods below.
241            
242             =cut
243              
244             sub plan {
245 23     23 1 227     my($self, $cmd, $arg) = @_;
246              
247 23 100       1993     return unless $cmd;
248              
249 11 50       136     if( $self->{Have_Plan} ) {
250 0         0         die sprintf "You tried to plan twice! Second plan at %s line %d\n",
251                       ($self->caller)[1,2];
252                 }
253              
254 11 50       243     if( $cmd eq 'no_plan' ) {
    50          
    50          
255 0         0         $self->no_plan;
256                 }
257                 elsif( $cmd eq 'skip_all' ) {
258 0         0         return $self->skip_all($arg);
259                 }
260                 elsif( $cmd eq 'tests' ) {
261 11 50       422         if( $arg ) {
    0          
    0          
262 11         137             return $self->expected_tests($arg);
263                     }
264                     elsif( !defined $arg ) {
265 0         0             die "Got an undefined number of tests. Looks like you tried to ".
266                             "say how many tests you plan to run but made a mistake.\n";
267                     }
268                     elsif( !$arg ) {
269 0         0             die "You said to run 0 tests! You've got to run something.\n";
270                     }
271                 }
272                 else {
273 0         0         require Carp;
274 0         0         my @args = grep { defined } ($cmd, $arg);
  0         0  
275 0         0         Carp::croak("plan() doesn't understand @args");
276                 }
277              
278 0         0     return 1;
279             }
280              
281             =item B<expected_tests>
282            
283             my $max = $Test->expected_tests;
284             $Test->expected_tests($max);
285            
286             Gets/sets the # of tests we expect this test to run and prints out
287             the appropriate headers.
288            
289             =cut
290              
291             sub expected_tests {
292 11     11 1 113     my $self = shift;
293 11         109     my($max) = @_;
294              
295 11 50       242     if( @_ ) {
296 11 50 33     394         die "Number of tests must be a postive integer. You gave it '$max'.\n"
297                       unless $max =~ /^\+?\d+$/ and $max > 0;
298              
299 11         719         $self->{Expected_Tests} = $max;
300 11         116         $self->{Have_Plan} = 1;
301              
302 11 50       915         $self->_print("1..$max\n") unless $self->no_header;
303                 }
304 11         243     return $self->{Expected_Tests};
305             }
306              
307              
308             =item B<no_plan>
309            
310             $Test->no_plan;
311            
312             Declares that this test will run an indeterminate # of tests.
313            
314             =cut
315              
316             sub no_plan {
317 0     0 1 0     my $self = shift;
318              
319 0         0     $self->{No_Plan} = 1;
320 0         0     $self->{Have_Plan} = 1;
321             }
322              
323             =item B<has_plan>
324            
325             $plan = $Test->has_plan
326            
327             Find out whether a plan has been defined. $plan is either C<undef> (no plan has been set), C<no_plan> (indeterminate # of tests) or an integer (the number of expected tests).
328            
329             =cut
330              
331             sub has_plan {
332 0     0 1 0     my $self = shift;
333              
334 0 0       0     return($self->{Expected_Tests}) if $self->{Expected_Tests};
335 0 0       0     return('no_plan') if $self->{No_Plan};
336 0         0     return(undef);
337             };
338              
339              
340             =item B<skip_all>
341            
342             $Test->skip_all;
343             $Test->skip_all($reason);
344            
345             Skips all the tests, using the given $reason. Exits immediately with 0.
346            
347             =cut
348              
349             sub skip_all {
350 0     0 1 0     my($self, $reason) = @_;
351              
352 0         0     my $out = "1..0";
353 0 0       0     $out .= " # Skip $reason" if $reason;
354 0         0     $out .= "\n";
355              
356 0         0     $self->{Skip_All} = 1;
357              
358 0 0       0     $self->_print($out) unless $self->no_header;
359 0         0     exit(0);
360             }
361              
362             =back
363            
364             =head2 Running tests
365            
366             These actually run the tests, analogous to the functions in
367             Test::More.
368            
369             $name is always optional.
370            
371             =over 4
372            
373             =item B<ok>
374