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            
375             $Test->ok($test, $name);
376            
377             Your basic test. Pass if $test is true, fail if $test is false. Just
378             like Test::Simple's ok().
379            
380             =cut
381              
382             sub ok {
383 2157     2157 1 29406     my($self, $test, $name) = @_;
384              
385             # $test might contain an object which we don't want to accidentally
386             # store, so we turn it into a boolean.
387 2157 50       29892     $test = $test ? 1 : 0;
388              
389 2157 50       33800     unless( $self->{Have_Plan} ) {
390 0         0         require Carp;
391 0         0         Carp::croak("You tried to run a test without a plan! Gotta have a plan.");
392                 }
393              
394 2157         32294     lock $self->{Curr_Test};
395 2157         22429     $self->{Curr_Test}++;
396              
397             # In case $name is a string overloaded object, force it to stringify.
398 2157         25810     $self->_unoverload_str(\$name);
399              
400 2157 50 66     46219     $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
401             You named your test '$name'. You shouldn't use numbers for your test names.
402             Very confusing.
403             ERR
404              
405 2157         27012     my($pack, $file, $line) = $self->caller;
406              
407 2157         35614     my $todo = $self->todo($pack);
408 2157         27794     $self->_unoverload_str(\$todo);
409              
410 2157         28682     my $out;
411 2157         44820     my $result = &share({});
412              
413 2157 50       45984     unless( $test ) {
414 0         0         $out .= "not ";
415 0 0       0         @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
416                 }
417                 else {
418 2157         37423         @$result{ 'ok', 'actual_ok' } = ( 1, $test );
419                 }
420              
421 2157         23962     $out .= "ok";
422 2157 50       26020     $out .= " $self->{Curr_Test}" if $self->use_numbers;
423              
424 2157 100       30612     if( defined $name ) {
425 2118         28035         $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
426 2118         21822         $out .= " - $name";
427 2118         29048         $result->{name} = $name;
428                 }
429                 else {
430 39         411         $result->{name} = '';
431                 }
432              
433 2157 50       20769     if( $todo ) {
434 0         0         $out .= " # TODO $todo";
435 0         0         $result->{reason} = $todo;
436 0         0         $result->{type} = 'todo';
437                 }
438                 else {
439 2157         76941         $result->{reason} = '';
440 2157         43294         $result->{type} = '';
441                 }
442              
443 2157         30924     $self->{Test_Results}[$self->{Curr_Test}-1] = $result;
444 2157         24958     $out .= "\n";
445              
446 2157         31563     $self->_print($out);
447              
448 2157 50       30399     unless( $test ) {
449 0 0       0         my $msg = $todo ? "Failed (TODO)" : "Failed";
450 0 0       0         $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
451              
452 0 0       0 if( defined $name ) {
453 0         0 $self->diag(qq[ $msg test '$name'\n]);
454 0         0 $self->diag(qq[ in $file at line $line.\n]);
455             }
456             else {
457 0         0 $self->diag(qq[ $msg test in $file at line $line.\n]);
458             }
459                 }
460              
461 2157 50       36182     return $test ? 1 : 0;
462             }
463              
464              
465             sub _unoverload {
466 20692     20692   370202     my $self = shift;
467 20692         292891     my $type = shift;
468              
469 20692         432381     local($@,$!);
470              
471 20692 50       320206     eval { require overload } || return;
  20692         455580  
472              
473 20692         291727     foreach my $thing (@_) {
474 37070         604649         eval {
475 37070 100       507782             if( _is_object($$thing) ) {
476 80 50       928                 if( my $string_meth = overload::Method($$thing, $type) ) {
477 0         0                     $$thing = $$thing->$string_meth();
478                             }
479                         }
480                     };
481                 }
482             }
483              
484              
485             sub _is_object {
486 37070     37070   563425     my $thing = shift;
487              
488 37070 100       466268     return eval { ref $thing && $thing->isa('UNIVERSAL') } ? 1 : 0;
  37070 100       894450  
489             }
490              
491              
492             sub _unoverload_str {
493 20692     20692   258973     my $self = shift;
494              
495 20692         296591     $self->_unoverload(q[""], @_);
496             }    
497              
498             sub _unoverload_num {
499 0     0   0     my $self = shift;
500              
501 0         0     $self->_unoverload('0+', @_);
502              
503 0         0     for my $val (@_) {
504 0 0       0         next unless $self->_is_dualvar($$val);
505 0         0         $$val = $$val+0;
506                 }
507             }
508              
509              
510             # This is a hack to detect a dualvar such as $!
511             sub _is_dualvar {
512 0     0   0     my($self, $val) = @_;
513              
514 0         0     local $^W = 0;
515 0         0     my $numval = $val+0;
516 0 0 0     0     return 1 if $numval != 0 and $numval ne $val;
517             }
518              
519              
520              
521             =item B<is_eq>
522            
523             $Test->is_eq($got, $expected, $name);
524            
525             Like Test::More's is(). Checks if $got eq $expected. This is the
526             string version.
527            
528             =item B<is_num>
529            
530             $Test->is_num($got, $expected, $name);
531            
532             Like Test::More's is(). Checks if $got == $expected. This is the
533             numeric version.
534            
535             =cut
536              
537             sub is_eq {
538 1592     1592 1 22037     my($self, $got, $expect, $name) = @_;
539 1592         18103     local $Level = $Level + 1;
540              
541 1592         29862     $self->_unoverload_str(\$got, \$expect);
542              
543 1592 100 66     28466     if( !defined $got || !defined $expect ) {
544             # undef only matches undef and nothing else
545 104   33     10325         my $test = !defined $got && !defined $expect;
546              
547 104         1131         $self->ok($test, $name);
548 104 50       1063         $self->_is_diag($got, 'eq', $expect) unless $test;
549 104         2944         return $test;
550                 }
551              
552 1488         18652     return $self->cmp_ok($got, 'eq', $expect, $name);
553             }
554              
555             sub is_num {
556 0     0 1 0     my($self, $got, $expect, $name) = @_;
557 0         0     local $Level = $Level + 1;
558              
559 0         0     $self->_unoverload_num(\$got, \$expect);
560              
561 0 0 0     0     if( !defined $got || !defined $expect ) {
562             # undef only matches undef and nothing else
563 0   0     0         my $test = !defined $got && !defined $expect;
564              
565 0         0         $self->ok($test, $name);
566 0 0       0         $self->_is_diag($got, '==', $expect) unless $test;
567 0         0         return $test;
568                 }
569              
570 0         0     return $self->cmp_ok($got, '==', $expect, $name);
571             }
572              
573             sub _is_diag {
574 0     0   0     my($self, $got, $type, $expect) = @_;
575              
576 0         0     foreach my $val (\$got, \$expect) {
577 0 0       0         if( defined $$val ) {
578 0 0       0             if( $type eq 'eq' ) {
579             # quote and force string context
580 0         0                 $$val = "'$$val'"
581                         }
582                         else {
583             # force numeric context
584 0         0                 $self->_unoverload_num($val);
585                         }
586                     }
587                     else {
588 0         0             $$val = 'undef';
589                     }
590                 }
591              
592 0         0     return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
593             got: %s
594             expected: %s
595             DIAGNOSTIC
596              
597             }    
598              
599             =item B<isnt_eq>
600            
601             $Test->isnt_eq($got, $dont_expect, $name);
602            
603             Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
604             the string version.
605            
606             =item B<isnt_num>
607            
608             $Test->isnt_num($got, $dont_expect, $name);
609            
610             Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
611             the numeric version.
612            
613             =cut
614              
615             sub isnt_eq {
616 0     0 1 0     my($self, $got, $dont_expect, $name) = @_;
617 0         0     local $Level = $Level + 1;
618              
619 0 0 0     0     if( !defined $got || !defined $dont_expect ) {
620             # undef only matches undef and nothing else
621 0   0     0         my $test = defined $got || defined $dont_expect;
622              
623 0         0         $self->ok($test, $name);
624 0 0       0         $self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
625 0         0         return $test;
626                 }
627              
628 0         0     return $self->cmp_ok($got, 'ne', $dont_expect, $name);
629             }
630              
631             sub isnt_num {
632 0     0 1 0     my($self, $got, $dont_expect, $name) = @_;
633 0         0     local $Level = $Level + 1;
634              
635 0 0 0     0     if( !defined $got || !defined $dont_expect ) {
636             # undef only matches undef and nothing else
637 0   0     0         my $test = defined $got || defined $dont_expect;
638              
639 0         0         $self->ok($test, $name);
640 0 0       0         $self->_cmp_diag($got, '!=', $dont_expect) unless $test;
641 0         0         return $test;
642                 }
643              
644 0         0     return $self->cmp_ok($got, '!=', $dont_expect, $name);
645             }
646              
647              
648             =item B<like>
649            
650             $Test->like($this, qr/$regex/, $name);
651             $Test->like($this, '/$regex/', $name);
652            
653             Like Test::More's like(). Checks if $this matches the given $regex.
654            
655             You'll want to avoid qr// if you want your tests to work before 5.005.
656            
657             =item B<unlike>
658            
659             $Test->unlike($this, qr/$regex/, $name);
660             $Test->unlike($this, '/$regex/', $name);
661            
662             Like Test::More's unlike(). Checks if $this B<does not match> the
663             given $regex.
664            
665             =cut
666              
667             sub like {
668 32     32 1 339     my($self, $this, $regex, $name) = @_;
669              
670 32         290     local $Level = $Level + 1;
671 32         13974     $self->_regex_ok($this, $regex, '=~', $name);
672             }
673              
674             sub unlike {
675 0     0 1 0     my($self, $this, $regex, $name) = @_;
676              
677 0         0     local $Level = $Level + 1;
678 0         0     $self->_regex_ok($this, $regex, '!~', $name);
679             }
680              
681             =item B<maybe_regex>
682            
683             $Test->maybe_regex(qr/$regex/);
684             $Test->maybe_regex('/$regex/');
685            
686             Convenience method for building testing functions that take regular
687             expressions as arguments, but need to work before perl 5.005.
688            
689             Takes a quoted regular expression produced by qr//, or a string
690             representing a regular expression.
691            
692             Returns a Perl value which may be used instead of the corresponding
693             regular expression, or undef if it's argument is not recognised.
694            
695             For example, a version of like(), sans the useful diagnostic messages,
696             could be written as:
697            
698             sub laconic_like {
699             my ($self, $this, $regex, $name) = @_;
700             my $usable_regex = $self->maybe_regex($regex);
701             die "expecting regex, found '$regex'\n"
702             unless $usable_regex;
703             $self->ok($this =~ m/$usable_regex/, $name);
704             }
705            
706             =cut
707              
708              
709             sub maybe_regex {
710 32     32 1 519     my ($self, $regex) = @_;
711 32         339     my $usable_regex = undef;
712              
713 32 50       310     return $usable_regex unless defined $regex;
714              
715 32         288     my($re, $opts);
716              
717             # Check for qr/foo/
718 32 50 0     341     if( ref $regex eq 'Regexp' ) {
    0          
719 32         1419         $usable_regex = $regex;
720                 }
721             # Check for '/foo/' or 'm,foo,'
722                 elsif( ($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
723                        (undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
724                      )
725                 {
726 0 0       0         $usable_regex = length $opts ? "(?$opts)$re" : $re;
727                 }
728              
729 32         309     return $usable_regex;
730             };
731              
732             sub _regex_ok {
733 32     32   339     my($self, $this, $regex, $cmp, $name) = @_;
734              
735 32         263     my $ok = 0;
736 32         314     my $usable_regex = $self->maybe_regex($regex);
737 32 50       306     unless (defined $usable_regex) {
738 0         0         $ok = $self->ok( 0, $name );
739 0         0         $self->diag(" '$regex' doesn't look much like a regex to me.");
740 0         0         return $ok;
741                 }
742              
743                 {
744 32         330         my $test;
  32         254  
745 32         325         my $code = $self->_caller_context;
746              
747 32         707         local($@, $!);
748              
749             # Yes, it has to look like this or 5.4.5 won't see the #line directive.
750             # Don't ask me, man, I just work here.
751 32         4360         $test = eval "
752             $code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
753              
754 32 50       1024         $test = !$test if $cmp eq '!~';
755              
756 32         318         local $Level = $Level + 1;
757 32         338         $ok = $self->ok( $test, $name );
758                 }
759              
760 32 50       361     unless( $ok ) {
761 0 0       0         $this = defined $this ? "'$this'" : 'undef';
762 0 0       0         my $match = $cmp eq '=~' ? "doesn't match" : "matches";
763 0         0         $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
764             %s
765             %13s '%s'
766             DIAGNOSTIC
767              
768                 }
769              
770 32         2233     return $ok;
771             }
772              
773             =item B<cmp_ok>
774            
775             $Test->cmp_ok($this, $type, $that, $name);
776            
777             Works just like Test::More's cmp_ok().
778            
779             $Test->cmp_ok($big_num, '!=', $other_big_num);
780            
781             =cut
782              
783              
784             my %numeric_cmps = map { ($_, 1) }
785                                    ("<", "<=", ">", ">=", "==", "!=", "<=>");
786              
787             sub cmp_ok {
788 1488     1488 1 16370     my($self, $got, $type, $expect, $name) = @_;
789              
790             # Treat overloaded objects as numbers if we're asked to do a
791             # numeric comparison.
792 1488 50       17584     my $unoverload = $numeric_cmps{$type} ? '_unoverload_num'
793                                                       : '_unoverload_str';
794              
795 1488         26715     $self->$unoverload(\$got, \$expect);
796              
797              
798 1488         15667     my $test;
799                 {
800 1488         13647         local($@,$!); # don't interfere with $@
  1488         28803  
801             # eval() sometimes resets $!
802              
803 1488         30119         my $code = $self->_caller_context;
804              
805             # Yes, it has to look like this or 5.4.5 won't see the #line directive.
806             # Don't ask me, man, I just work here.
807 1488         118543         $test = eval "
808             $code" . "\$got $type \$expect;";
809              
810                 }
811 1488         66144     local $Level = $Level + 1;
812 1488         17180     my $ok = $self->ok($test, $name);
813              
814 1488 50       15962     unless( $ok ) {
815 0 0       0         if( $type =~ /^(eq|==)$/ ) {
816 0         0             $self->_is_diag($got, $type, $expect);
817                     }
818                     else {
819 0         0             $self->_cmp_diag($got, $type, $expect);
820                     }
821                 }
822 1488         33797     return $ok;
823             }
824              
825             sub _cmp_diag {
826 0     0   0     my($self, $got, $type, $expect) = @_;
827                 
828 0 0       0     $got = defined $got ? "'$got'" : 'undef';
829 0 0       0     $expect = defined $expect ? "'$expect'" : 'undef';
830 0         0     return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
831             %s
832             %s
833             %s
834             DIAGNOSTIC
835             }
836              
837              
838             sub _caller_context {
839 1520     1520   16918     my $self = shift;
840              
841 1520         68601     my($pack, $file, $line) = $self->caller(1);
842              
843 1520         20170     my $code = '';
844 1520 50 33     29780     $code .= "#line $line $file\n" if defined $file and defined $line;
845              
846 1520         23755     return $code;
847             }
848              
849              
850             =item B<BAIL_OUT>
851            
852             $Test->BAIL_OUT($reason);
853            
854             Indicates to the Test::Harness that things are going so badly all
855             testing should terminate. This includes running any additional test
856             scripts.
857            
858             It will exit with 255.
859            
860             =cut
861              
862             sub BAIL_OUT {
863 0     0 1 0     my($self, $reason) = @_;
864              
865 0         0     $self->{Bailed_Out} = 1;
866 0         0     $self->_print("Bail out! $reason");
867 0         0     exit 255;
868             }
869              
870             =for deprecated
871             BAIL_OUT() used to be BAILOUT()
872            
873             =cut
874              
875             *BAILOUT = \&BAIL_OUT;
876              
877              
878             =item B<skip>
879            
880             $Test->skip;
881             $Test->skip($why);
882            
883             Skips the current test, reporting $why.
884            
885             =cut
886              
887             sub skip {
888 0     0 1 0     my($self, $why) = @_;
889 0   0     0     $why ||= '';
890 0         0     $self->_unoverload_str(\$why);
891              
892 0 0       0     unless( $self->{Have_Plan} ) {
893 0         0         require Carp;
894 0         0         Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
895                 }
896              
897 0         0     lock($self->{Curr_Test});
898 0         0     $self->{Curr_Test}++;
899              
900 0         0     $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
901                     'ok' => 1,
902                     actual_ok => 1,
903                     name => '',
904                     type => 'skip',
905                     reason => $why,
906                 });
907              
908 0         0     my $out = "ok";
909 0 0       0     $out .= " $self->{Curr_Test}" if $self->use_numbers;
910 0         0     $out .= " # skip";
911 0 0       0     $out .= " $why" if length $why;
912 0         0     $out .= "\n";
913              
914 0         0     $self->_print($out);
915              
916 0         0     return 1;
917             }
918              
919              
920             =item B<todo_skip>
921            
922             $Test->todo_skip;
923             $Test->todo_skip($why);
924            
925             Like skip(), only it will declare the test as failing and TODO. Similar
926             to
927            
928             print "not ok $tnum # TODO $why\n";
929            
930             =cut
931              
932             sub todo_skip {
933 0     0 1 0     my($self, $why) = @_;
934 0   0     0     $why ||= '';
935              
936 0 0       0     unless( $self->{Have_Plan} ) {
937 0         0         require Carp;
938 0         0         Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
939                 }
940              
941 0         0     lock($self->{Curr_Test});
942 0         0     $self->{Curr_Test}++;
943              
944 0         0     $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
945                     'ok' => 1,
946                     actual_ok => 0,
947                     name => '',
948                     type => 'todo_skip',
949                     reason => $why,
950                 });
951              
952 0         0     my $out = "not ok";
953 0 0       0     $out .= " $self->{Curr_Test}" if $self->use_numbers;
954 0         0     $out .= " # TODO & SKIP $why\n";
955              
956 0         0     $self->_print($out);
957              
958 0         0     return 1;
959             }
960              
961              
962             =begin _unimplemented
963            
964             =item B<skip_rest>
965            
966             $Test->skip_rest;
967             $Test->skip_rest($reason);
968            
969             Like skip(), only it skips all the rest of the tests you plan to run
970             and terminates the test.
971            
972             If you're running under no_plan, it skips once and terminates the
973             test.
974            
975             =end _unimplemented
976            
977             =back
978            
979            
980             =head2 Test style
981            
982             =over 4
983            
984             =item B<level>
985            
986             $Test->level($how_high);
987            
988             How far up the call stack should $Test look when reporting where the
989             test failed.
990            
991             Defaults to 1.
992            
993             Setting $Test::Builder::Level overrides. This is typically useful
994             localized:
995            
996             {
997             local $Test::Builder::Level = 2;
998             $Test->ok($test);
999             }
1000            
1001             =cut
1002              
1003             sub level {
1004 3677     3677 1 63140     my($self, $level) = @_;
1005              
1006 3677 50       53401     if( defined $level ) {
1007 0         0         $Level = $level;
1008                 }
1009 3677         111869     return $Level;
1010             }
1011              
1012              
1013             =item B<use_numbers>
1014            
1015             $Test->use_numbers($on_or_off);
1016            
1017             Whether or not the test should output numbers. That is, this if true:
1018            
1019             ok 1
1020             ok 2
1021             ok 3
1022            
1023             or this if false
1024            
1025             ok
1026             ok
1027             ok
1028            
1029             Most useful when you can't depend on the test output order, such as
1030             when threads or forking is involved.
1031            
1032             Test::Harness will accept either, but avoid mixing the two styles.
1033            
1034             Defaults to on.
1035            
1036             =cut
1037              
1038             sub use_numbers {
1039 2157     2157 1 25108     my($self, $use_nums) = @_;
1040              
1041 2157 50       24049     if( defined $use_nums ) {
1042 0         0         $self->{Use_Nums} = $use_nums;
1043                 }
1044 2157         33566     return $self->{Use_Nums};
1045             }
1046              
1047              
1048             =item B<no_diag>
1049            
1050             $Test->no_diag($no_diag);
1051            
1052             If set true no diagnostics will be printed. This includes calls to
1053             diag().
1054            
1055             =item B<no_ending>
1056            
1057             $Test->no_ending($no_ending);
1058            
1059             Normally, Test::Builder does some extra diagnostics when the test
1060             ends. It also changes the exit code as described below.
1061            
1062             If this is true, none of that will be done.
1063            
1064             =item B<no_header>
1065            
1066             $Test->no_header($no_header);
1067            
1068             If set to true, no "1..N" header will be printed.
1069            
1070             =cut
1071              
1072             foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
1073                 my $method = lc $attribute;
1074              
1075                 my $code = sub {
1076 22     22   251         my($self, $no) = @_;
1077              
1078 22 50       238         if( defined $no ) {
1079 0         0             $self->{$attribute} = $no;
1080                     }
1081 22         458         return $self->{$attribute};
1082                 };
1083              
1084 11     11   244     no strict 'refs';
  11         111  
  11         194  
1085                 *{__PACKAGE__.'::'.$method} = $code;
1086             }
1087              
1088              
1089             =back
1090            
1091             =head2 Output
1092            
1093             Controlling where the test output goes.
1094            
1095             It's ok for your test to change where STDOUT and STDERR point to,
1096             Test::Builder's default output settings will not be affected.
1097            
1098             =over 4
1099            
1100             =item B<diag>
1101            
1102             $Test->diag(@msgs);
1103            
1104             Prints out the given @msgs. Like C<print>, arguments are simply
1105             appended together.
1106            
1107             Normally, it uses the failure_output() handle, but if this is for a
1108             TODO test, the todo_output() handle is used.
1109            
1110             Output will be indented and marked with a # so as not to interfere
1111             with test output. A newline will be put on the end if there isn't one
1112             already.
1113            
1114             We encourage using this rather than calling print directly.
1115            
1116             Returns false. Why? Because diag() is often used in conjunction with
1117             a failing test (C<ok() || diag()>) it "passes through" the failure.
1118            
1119             return ok(...) || diag(...);
1120            
1121             =for blame transfer
1122             Mark Fowler <mark@twoshortplanks.com>
1123            
1124             =cut
1125              
1126             sub diag {
1127 0     0 1 0     my($self, @msgs) = @_;
1128              
1129 0 0       0     return if $self->no_diag;
1130 0 0       0     return unless @msgs;
1131              
1132             # Prevent printing headers when compiling (i.e. -c)
1133 0 0       0     return if $^C;
1134              
1135             # Smash args together like print does.
1136             # Convert undef to 'undef' so its readable.
1137 0 0       0     my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
  0         0  
1138              
1139             # Escape each line with a #.
1140 0         0     $msg =~ s/^/# /gm;
1141              
1142             # Stick a newline on the end if it needs it.
1143 0 0       0     $msg .= "\n" unless $msg =~ /\n\Z/;
1144              
1145 0         0     local $Level = $Level + 1;
1146 0         0     $self->_print_diag($msg);
1147              
1148 0         0     return 0;
1149             }
1150              
1151             =begin _private
1152            
1153             =item B<_print>
1154            
1155             $Test->_print(@msgs);
1156            
1157             Prints to the output() filehandle.
1158            
1159             =end _private
1160            
1161             =cut
1162              
1163             sub _print {
1164 2168     2168   85092     my($self, @msgs) = @_;
1165              
1166             # Prevent printing headers when only compiling. Mostly for when
1167             # tests are deparsed with B::Deparse
1168 2168 50       29177     return if $^C;
1169              
1170 2168         28487     my $msg = join '', @msgs;
1171              
1172 2168         37633     local($\, $", $,) = (undef, ' ', '');
1173 2168         27329     my $fh = $self->output;
1174              
1175             # Escape each line after the first with a # so we don't
1176             # confuse Test::Harness.
1177 2168         24767     $msg =~ s/\n(.)/\n# $1/sg;
1178              
1179             # Stick a newline on the end if it needs it.
1180 2168 50       30067     $msg .= "\n" unless $msg =~ /\n\Z/;
1181              
1182 2168         501708     print $fh $msg;
1183             }
1184              
1185              
1186             =item B<_print_diag>
1187            
1188             $Test->_print_diag(@msg);
1189            
1190             Like _print, but prints to the current diagnostic filehandle.
1191            
1192             =cut
1193              
1194             sub _print_diag {
1195 0     0   0     my $self = shift;
1196              
1197 0         0     local($\, $", $,) = (undef, ' ', '');
1198 0 0       0     my $fh = $self->todo ? $self->todo_output : $self->failure_output;
1199 0         0     print $fh @_;
1200             }    
1201              
1202             =item B<output>
1203            
1204             $Test->output($fh);
1205             $Test->output($file);
1206            
1207             Where normal "ok/not ok" test output should go.
1208            
1209             Defaults to STDOUT.
1210            
1211             =item B<failure_output>
1212            
1213             $Test->failure_output($fh);
1214             $Test->failure_output($file);
1215            
1216             Where diagnostic output on test failures and diag() should go.
1217            
1218             Defaults to STDERR.
1219            
1220             =item B<todo_output>
1221            
1222             $Test->todo_output($fh);
1223             $Test->todo_output($file);
1224            
1225             Where diagnostics about todo test failures and diag() should go.
1226            
1227             Defaults to STDOUT.
1228            
1229             =cut
1230              
1231             sub output {
1232 2179     2179 1 34679     my($self, $fh) = @_;
1233              
1234 2179 100       25763     if( defined $fh ) {
1235 11         120         $self->{Out_FH} = _new_fh($fh);
1236                 }
1237 2179         33328     return $self->{Out_FH};
1238             }
1239              
1240             sub failure_output {
1241 11     11 1 110     my($self, $fh) = @_;
1242              
1243 11 50       163     if( defined $fh ) {
1244 11         107         $self->{Fail_FH} = _new_fh($fh);
1245                 }
1246 11         117     return $self->{Fail_FH};
1247             }
1248              
1249             sub todo_output {
1250 11     11 1 106     my($self, $fh) = @_;
1251              
1252 11 50       125     if( defined $fh ) {
1253 11         110         $self->{Todo_FH} = _new_fh($fh);
1254                 }
1255 11         122     return $self->{Todo_FH};
1256             }
1257              
1258              
1259             sub _new_fh {
1260 33     33   295     my($file_or_fh) = shift;
1261              
1262 33         401     my $fh;
1263 33 50       356     if( _is_fh($file_or_fh) ) {
1264 33         306         $fh = $file_or_fh;
1265                 }
1266                 else {
1267 0         0         $fh = do { local *FH };
  0         0  
1268 0 0       0         open $fh, ">$file_or_fh" or
1269                         die "Can't open test output log $file_or_fh: $!";
1270 0         0 _autoflush($fh);
1271                 }
1272              
1273 33         367     return $fh;
1274             }
1275              
1276              
1277             sub _is_fh {
1278 33     33   280     my $maybe_fh = shift;
1279 33 50       417     return 0 unless defined $maybe_fh;
1280              
1281 33 50       588     return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
1282              
1283 33   33     932     return UNIVERSAL::isa($maybe_fh, 'GLOB') ||
      0        
      33        
1284                        UNIVERSAL::isa($maybe_fh, 'IO::Handle') ||
1285              
1286             # 5.5.4's tied() and can() doesn't like getting undef
1287                        UNIVERSAL::can((tied($maybe_fh) || ''), 'TIEHANDLE');
1288             }
1289              
1290              
1291             sub _autoflush {
1292 44     44   430     my($fh) = shift;
1293 44         1511     my $old_fh = select $fh;
1294 44         391     $| = 1;
1295 44         498     select $old_fh;
1296             }
1297              
1298              
1299             sub _dup_stdhandles {
1300 11     11   109     my $self = shift;
1301              
1302 11         642     $self->_open_testhandles;
1303              
1304             # Set everything to unbuffered else plain prints to STDOUT will
1305             # come out in the wrong order from our own prints.
1306 11         186     _autoflush(\*TESTOUT);
1307 11         149     _autoflush(\*STDOUT);
1308 11         116     _autoflush(\*TESTERR);
1309 11         209     _autoflush(\*STDERR);
1310              
1311 11         171     $self->output(\*TESTOUT);
1312 11         371     $self->failure_output(\*TESTERR);
1313 11         135     $self->todo_output(\*TESTOUT);
1314             }
1315              
1316              
1317             my $Opened_Testhandles = 0;
1318             sub _open_testhandles {
1319 11 50   11   2803     return if $Opened_Testhandles;
1320             # We dup STDOUT and STDERR so people can change them in their
1321             # test suites while still getting normal test output.
1322 11 50       1341     open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
1323 11 50       521     open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
1324 11         125     $Opened_Testhandles = 1;
1325             }
1326              
1327              
1328             =back
1329            
1330            
1331             =head2 Test Status and Info
1332            
1333             =over 4
1334            
1335             =item B<current_test>
1336            
1337             my $curr_test = $Test->current_test;
1338             $Test->current_test($num);
1339            
1340             Gets/sets the current test number we're on. You usually shouldn't
1341             have to set this.
1342            
1343             If set forward, the details of the missing tests are filled in as 'unknown'.
1344             if set backward, the details of the intervening tests are deleted. You
1345             can erase history if you really want to.
1346            
1347             =cut
1348              
1349             sub current_test {
1350 0     0 1 0     my($self, $num) = @_;
1351              
1352 0         0     lock($self->{Curr_Test});
1353 0 0       0     if( defined $num ) {
1354 0 0       0         unless( $self->{Have_Plan} ) {
1355 0         0             require Carp;
1356 0         0             Carp::croak("Can't change the current test number without a plan!");
1357                     }
1358              
1359 0         0         $self->{Curr_Test} = $num;
1360              
1361             # If the test counter is being pushed forward fill in the details.
1362 0         0         my $test_results = $self->{Test_Results};
1363 0 0       0         if( $num > @$test_results ) {
    0          
1364 0 0       0             my $start = @$test_results ? @$test_results : 0;
1365 0         0             for ($start..$num-1) {
1366 0         0                 $test_results->[$_] = &share({
1367                                 'ok' => 1,
1368                                 actual_ok => undef,
1369                                 reason => 'incrementing test number',
1370                                 type => 'unknown',
1371                                 name => undef
1372                             });
1373                         }
1374                     }
1375             # If backward, wipe history. Its their funeral.
1376                     elsif( $num < @$test_results ) {
1377 0         0             $#{$test_results} = $num - 1;
  0         0  
1378                     }
1379                 }
1380 0         0     return $self->{Curr_Test};
1381             }
1382              
1383              
1384             =item B<summary>
1385            
1386             my @tests = $Test->summary;
1387            
1388             A simple summary of the tests so far. True for pass, false for fail.
1389             This is a logical pass/fail, so todos are passes.
1390            
1391             Of course, test #1 is $tests[0], etc...
1392            
1393             =cut
1394              
1395             sub summary {
1396 0     0 1 0     my($self) = shift;
1397              
1398 0         0     return map { $_->{'ok'} } @{ $self->{Test_Results} };
  0         0  
  0         0  
1399             }
1400              
1401             =item B<details>
1402            
1403             my @tests = $Test->details;
1404            
1405             Like summary(), but with a lot more detail.
1406            
1407             $tests[$test_num - 1] =
1408             { 'ok' => is the test considered a pass?
1409             actual_ok => did it literally say 'ok'?
1410             name => name of the test (if any)
1411             type => type of test (if any, see below).
1412             reason => reason for the above (if any)
1413             };
1414            
1415             'ok' is true if Test::Harness will consider the test to be a pass.
1416            
1417             'actual_ok' is a reflection of whether or not the test literally
1418             printed 'ok' or 'not ok'. This is for examining the result of 'todo'
1419             tests.
1420            
1421             'name' is the name of the test.
1422            
1423             'type' indicates if it was a special test. Normal tests have a type
1424             of ''. Type can be one of the following:
1425            
1426             skip see skip()
1427             todo see todo()
1428             todo_skip see todo_skip()
1429             unknown see below
1430            
1431             Sometimes the Test::Builder test counter is incremented without it
1432             printing any test output, for example, when current_test() is changed.
1433             In these cases, Test::Builder doesn't know the result of the test, so
1434             it's type is 'unkown'. These details for these tests are filled in.
1435             They are considered ok, but the name and actual_ok is left undef.
1436            
1437             For example "not ok 23 - hole count # TODO insufficient donuts" would
1438             result in this structure:
1439            
1440             $tests[22] = # 23 - 1, since arrays start from 0.
1441             { ok => 1, # logically, the test passed since it's todo
1442             actual_ok => 0, # in absolute terms, it failed
1443             name => 'hole count',
1444             type => 'todo',
1445             reason => 'insufficient donuts'
1446             };
1447            
1448             =cut
1449              
1450             sub details {
1451 0     0 1 0     my $self = shift;
1452 0         0     return @{ $self->{Test_Results} };
  0         0  
1453             }
1454              
1455             =item B<todo>
1456            
1457             my $todo_reason = $Test->todo;
1458             my $todo_reason = $Test->todo($pack);
1459            
1460             todo() looks for a $TODO variable in your tests. If set, all tests
1461             will be considered 'todo' (see Test::More and Test::Harness for
1462             details). Returns the reason (ie. the value of $TODO) if running as
1463             todo tests, false otherwise.
1464            
1465             todo() is about finding the right package to look for $TODO in. It
1466             uses the exported_to() package to find it. If that's not set, it's
1467             pretty good at guessing the right package to look at based on $Level.
1468            
1469             Sometimes there is some confusion about where todo() should be looking
1470             for the $TODO variable. If you want to be sure, tell it explicitly
1471             what $pack to use.
1472            
1473             =cut
1474              
1475             sub todo {
1476 2157     2157 1 78570     my($self, $pack) = @_;
1477              
1478 2157   33     25123     $pack = $pack || $self->exported_to || $self->caller($Level);
      33        
1479 2157 50       22091     return 0 unless $pack;
1480              
1481 11     11   366     no strict 'refs';
  11         2497  
  11         225  
1482 2157 50       20744     return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
  2157         71119  
  0         0  
1483                                                  : 0;
1484             }
1485              
1486             =item B<caller>
1487            
1488             my $package = $Test->caller;
1489             my($pack, $file, $line) = $Test->caller;
1490             my($pack, $file, $line) = $Test->caller($height);
1491            
1492             Like the normal caller(), except it reports according to your level().
1493            
1494             =cut
1495              
1496             sub caller {
1497 3677     3677 1 52572     my($self, $height) = @_;
1498 3677   100     42716     $height ||= 0;
1499              
1500 3677         43305     my @caller = CORE::caller($self->level + $height + 1);
1501 3677 50       70407     return wantarray ? @caller : $caller[0];
1502             }
1503              
1504             =back
1505            
1506             =cut
1507              
1508             =begin _private
1509            
1510             =over 4
1511            
1512             =item B<_sanity_check>
1513            
1514             $self->_sanity_check();
1515            
1516             Runs a bunch of end of test sanity checks to make sure reality came
1517             through ok. If anything is wrong it will die with a fairly friendly
1518             error message.
1519            
1520             =cut
1521              
1522             #'#
1523             sub _sanity_check {
1524 11     11   106     my $self = shift;
1525              
1526 11         143     _whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!');
1527 11   33     215     _whoa(!