sync a bunch of files with Test::Simple 0.86
[perl.git] / lib / Test / Builder.pm
1 package Test::Builder;
2 # $Id$
3
4 use 5.006;
5 use strict;
6 use warnings;
7
8 our $VERSION = '0.86';
9 $VERSION = eval $VERSION;    ## no critic (BuiltinFunctions::ProhibitStringyEval)
10
11 # Make Test::Builder thread-safe for ithreads.
12 BEGIN {
13     use Config;
14     # Load threads::shared when threads are turned on.
15     # 5.8.0's threads are so busted we no longer support them.
16     if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
17         require threads::shared;
18
19         # Hack around YET ANOTHER threads::shared bug.  It would
20         # occassionally forget the contents of the variable when sharing it.
21         # So we first copy the data, then share, then put our copy back.
22         *share = sub (\[$@%]) {
23             my $type = ref $_[0];
24             my $data;
25
26             if( $type eq 'HASH' ) {
27                 %$data = %{ $_[0] };
28             }
29             elsif( $type eq 'ARRAY' ) {
30                 @$data = @{ $_[0] };
31             }
32             elsif( $type eq 'SCALAR' ) {
33                 $$data = ${ $_[0] };
34             }
35             else {
36                 die( "Unknown type: " . $type );
37             }
38
39             $_[0] = &threads::shared::share( $_[0] );
40
41             if( $type eq 'HASH' ) {
42                 %{ $_[0] } = %$data;
43             }
44             elsif( $type eq 'ARRAY' ) {
45                 @{ $_[0] } = @$data;
46             }
47             elsif( $type eq 'SCALAR' ) {
48                 ${ $_[0] } = $$data;
49             }
50             else {
51                 die( "Unknown type: " . $type );
52             }
53
54             return $_[0];
55         };
56     }
57     # 5.8.0's threads::shared is busted when threads are off
58     # and earlier Perls just don't have that module at all.
59     else {
60         *share = sub { return $_[0] };
61         *lock  = sub { 0 };
62     }
63 }
64
65 =head1 NAME
66
67 Test::Builder - Backend for building test libraries
68
69 =head1 SYNOPSIS
70
71   package My::Test::Module;
72   use base 'Test::Builder::Module';
73
74   my $CLASS = __PACKAGE__;
75
76   sub ok {
77       my($test, $name) = @_;
78       my $tb = $CLASS->builder;
79
80       $tb->ok($test, $name);
81   }
82
83
84 =head1 DESCRIPTION
85
86 Test::Simple and Test::More have proven to be popular testing modules,
87 but they're not always flexible enough.  Test::Builder provides the a
88 building block upon which to write your own test libraries I<which can
89 work together>.
90
91 =head2 Construction
92
93 =over 4
94
95 =item B<new>
96
97   my $Test = Test::Builder->new;
98
99 Returns a Test::Builder object representing the current state of the
100 test.
101
102 Since you only run one test per program C<new> always returns the same
103 Test::Builder object.  No matter how many times you call new(), you're
104 getting the same object.  This is called a singleton.  This is done so that
105 multiple modules share such global information as the test counter and
106 where test output is going.
107
108 If you want a completely new Test::Builder object different from the
109 singleton, use C<create>.
110
111 =cut
112
113 my $Test = Test::Builder->new;
114
115 sub new {
116     my($class) = shift;
117     $Test ||= $class->create;
118     return $Test;
119 }
120
121 =item B<create>
122
123   my $Test = Test::Builder->create;
124
125 Ok, so there can be more than one Test::Builder object and this is how
126 you get it.  You might use this instead of C<new()> if you're testing
127 a Test::Builder based module, but otherwise you probably want C<new>.
128
129 B<NOTE>: the implementation is not complete.  C<level>, for example, is
130 still shared amongst B<all> Test::Builder objects, even ones created using
131 this method.  Also, the method name may change in the future.
132
133 =cut
134
135 sub create {
136     my $class = shift;
137
138     my $self = bless {}, $class;
139     $self->reset;
140
141     return $self;
142 }
143
144 =item B<reset>
145
146   $Test->reset;
147
148 Reinitializes the Test::Builder singleton to its original state.
149 Mostly useful for tests run in persistent environments where the same
150 test might be run multiple times in the same process.
151
152 =cut
153
154 our $Level;
155
156 sub reset {    ## no critic (Subroutines::ProhibitBuiltinHomonyms)
157     my($self) = @_;
158
159     # We leave this a global because it has to be localized and localizing
160     # hash keys is just asking for pain.  Also, it was documented.
161     $Level = 1;
162
163     $self->{Have_Plan}    = 0;
164     $self->{No_Plan}      = 0;
165     $self->{Original_Pid} = $$;
166
167     share( $self->{Curr_Test} );
168     $self->{Curr_Test} = 0;
169     $self->{Test_Results} = &share( [] );
170
171     $self->{Exported_To}    = undef;
172     $self->{Expected_Tests} = 0;
173
174     $self->{Skip_All} = 0;
175
176     $self->{Use_Nums} = 1;
177
178     $self->{No_Header} = 0;
179     $self->{No_Ending} = 0;
180
181     $self->{Todo}       = undef;
182     $self->{Todo_Stack} = [];
183     $self->{Start_Todo} = 0;
184
185     $self->_dup_stdhandles;
186
187     return;
188 }
189
190 =back
191
192 =head2 Setting up tests
193
194 These methods are for setting up tests and declaring how many there
195 are.  You usually only want to call one of these methods.
196
197 =over 4
198
199 =item B<plan>
200
201   $Test->plan('no_plan');
202   $Test->plan( skip_all => $reason );
203   $Test->plan( tests => $num_tests );
204
205 A convenient way to set up your tests.  Call this and Test::Builder
206 will print the appropriate headers and take the appropriate actions.
207
208 If you call plan(), don't call any of the other methods below.
209
210 =cut
211
212 sub plan {
213     my( $self, $cmd, $arg ) = @_;
214
215     return unless $cmd;
216
217     local $Level = $Level + 1;
218
219     $self->croak("You tried to plan twice")
220       if $self->{Have_Plan};
221
222     if( $cmd eq 'no_plan' ) {
223         $self->carp("no_plan takes no arguments") if $arg;
224         $self->no_plan;
225     }
226     elsif( $cmd eq 'skip_all' ) {
227         return $self->skip_all($arg);
228     }
229     elsif( $cmd eq 'tests' ) {
230         if($arg) {
231             local $Level = $Level + 1;
232             return $self->expected_tests($arg);
233         }
234         elsif( !defined $arg ) {
235             $self->croak("Got an undefined number of tests");
236         }
237         else {
238             $self->croak("You said to run 0 tests");
239         }
240     }
241     else {
242         my @args = grep { defined } ( $cmd, $arg );
243         $self->croak("plan() doesn't understand @args");
244     }
245
246     return 1;
247 }
248
249 =item B<expected_tests>
250
251     my $max = $Test->expected_tests;
252     $Test->expected_tests($max);
253
254 Gets/sets the # of tests we expect this test to run and prints out
255 the appropriate headers.
256
257 =cut
258
259 sub expected_tests {
260     my $self = shift;
261     my($max) = @_;
262
263     if(@_) {
264         $self->croak("Number of tests must be a positive integer.  You gave it '$max'")
265           unless $max =~ /^\+?\d+$/;
266
267         $self->{Expected_Tests} = $max;
268         $self->{Have_Plan}      = 1;
269
270         $self->_print("1..$max\n") unless $self->no_header;
271     }
272     return $self->{Expected_Tests};
273 }
274
275 =item B<no_plan>
276
277   $Test->no_plan;
278
279 Declares that this test will run an indeterminate # of tests.
280
281 =cut
282
283 sub no_plan {
284     my $self = shift;
285
286     $self->{No_Plan}   = 1;
287     $self->{Have_Plan} = 1;
288
289     return 1;
290 }
291
292 =item B<has_plan>
293
294   $plan = $Test->has_plan
295
296 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).
297
298 =cut
299
300 sub has_plan {
301     my $self = shift;
302
303     return( $self->{Expected_Tests} ) if $self->{Expected_Tests};
304     return('no_plan') if $self->{No_Plan};
305     return(undef);
306 }
307
308 =item B<skip_all>
309
310   $Test->skip_all;
311   $Test->skip_all($reason);
312
313 Skips all the tests, using the given $reason.  Exits immediately with 0.
314
315 =cut
316
317 sub skip_all {
318     my( $self, $reason ) = @_;
319
320     my $out = "1..0";
321     $out .= " # Skip $reason" if $reason;
322     $out .= "\n";
323
324     $self->{Skip_All} = 1;
325
326     $self->_print($out) unless $self->no_header;
327     exit(0);
328 }
329
330 =item B<exported_to>
331
332   my $pack = $Test->exported_to;
333   $Test->exported_to($pack);
334
335 Tells Test::Builder what package you exported your functions to.
336
337 This method isn't terribly useful since modules which share the same
338 Test::Builder object might get exported to different packages and only
339 the last one will be honored.
340
341 =cut
342
343 sub exported_to {
344     my( $self, $pack ) = @_;
345
346     if( defined $pack ) {
347         $self->{Exported_To} = $pack;
348     }
349     return $self->{Exported_To};
350 }
351
352 =back
353
354 =head2 Running tests
355
356 These actually run the tests, analogous to the functions in Test::More.
357
358 They all return true if the test passed, false if the test failed.
359
360 $name is always optional.
361
362 =over 4
363
364 =item B<ok>
365
366   $Test->ok($test, $name);
367
368 Your basic test.  Pass if $test is true, fail if $test is false.  Just
369 like Test::Simple's ok().
370
371 =cut
372
373 sub ok {
374     my( $self, $test, $name ) = @_;
375
376     # $test might contain an object which we don't want to accidentally
377     # store, so we turn it into a boolean.
378     $test = $test ? 1 : 0;
379
380     $self->_plan_check;
381
382     lock $self->{Curr_Test};
383     $self->{Curr_Test}++;
384
385     # In case $name is a string overloaded object, force it to stringify.
386     $self->_unoverload_str( \$name );
387
388     $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
389     You named your test '$name'.  You shouldn't use numbers for your test names.
390     Very confusing.
391 ERR
392
393     # Capture the value of $TODO for the rest of this ok() call
394     # so it can more easily be found by other routines.
395     my $todo    = $self->todo();
396     my $in_todo = $self->in_todo;
397     local $self->{Todo} = $todo if $in_todo;
398
399     $self->_unoverload_str( \$todo );
400
401     my $out;
402     my $result = &share( {} );
403
404     unless($test) {
405         $out .= "not ";
406         @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
407     }
408     else {
409         @$result{ 'ok', 'actual_ok' } = ( 1, $test );
410     }
411
412     $out .= "ok";
413     $out .= " $self->{Curr_Test}" if $self->use_numbers;
414
415     if( defined $name ) {
416         $name =~ s|#|\\#|g;    # # in a name can confuse Test::Harness.
417         $out .= " - $name";
418         $result->{name} = $name;
419     }
420     else {
421         $result->{name} = '';
422     }
423
424     if( $self->in_todo ) {
425         $out .= " # TODO $todo";
426         $result->{reason} = $todo;
427         $result->{type}   = 'todo';
428     }
429     else {
430         $result->{reason} = '';
431         $result->{type}   = '';
432     }
433
434     $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
435     $out .= "\n";
436
437     $self->_print($out);
438
439     unless($test) {
440         my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
441         $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
442
443         my( undef, $file, $line ) = $self->caller;
444         if( defined $name ) {
445             $self->diag(qq[  $msg test '$name'\n]);
446             $self->diag(qq[  at $file line $line.\n]);
447         }
448         else {
449             $self->diag(qq[  $msg test at $file line $line.\n]);
450         }
451     }
452
453     return $test ? 1 : 0;
454 }
455
456 sub _unoverload {
457     my $self = shift;
458     my $type = shift;
459
460     $self->_try(sub { require overload; }, die_on_fail => 1);
461
462     foreach my $thing (@_) {
463         if( $self->_is_object($$thing) ) {
464             if( my $string_meth = overload::Method( $$thing, $type ) ) {
465                 $$thing = $$thing->$string_meth();
466             }
467         }
468     }
469
470     return;
471 }
472
473 sub _is_object {
474     my( $self, $thing ) = @_;
475
476     return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
477 }
478
479 sub _unoverload_str {
480     my $self = shift;
481
482     return $self->_unoverload( q[""], @_ );
483 }
484
485 sub _unoverload_num {
486     my $self = shift;
487
488     $self->_unoverload( '0+', @_ );
489
490     for my $val (@_) {
491         next unless $self->_is_dualvar($$val);
492         $$val = $$val + 0;
493     }
494
495     return;
496 }
497
498 # This is a hack to detect a dualvar such as $!
499 sub _is_dualvar {
500     my( $self, $val ) = @_;
501
502     # Objects are not dualvars.
503     return 0 if ref $val;
504
505     no warnings 'numeric';
506     my $numval = $val + 0;
507     return $numval != 0 and $numval ne $val ? 1 : 0;
508 }
509
510 =item B<is_eq>
511
512   $Test->is_eq($got, $expected, $name);
513
514 Like Test::More's is().  Checks if $got eq $expected.  This is the
515 string version.
516
517 =item B<is_num>
518
519   $Test->is_num($got, $expected, $name);
520
521 Like Test::More's is().  Checks if $got == $expected.  This is the
522 numeric version.
523
524 =cut
525
526 sub is_eq {
527     my( $self, $got, $expect, $name ) = @_;
528     local $Level = $Level + 1;
529
530     $self->_unoverload_str( \$got, \$expect );
531
532     if( !defined $got || !defined $expect ) {
533         # undef only matches undef and nothing else
534         my $test = !defined $got && !defined $expect;
535
536         $self->ok( $test, $name );
537         $self->_is_diag( $got, 'eq', $expect ) unless $test;
538         return $test;
539     }
540
541     return $self->cmp_ok( $got, 'eq', $expect, $name );
542 }
543
544 sub is_num {
545     my( $self, $got, $expect, $name ) = @_;
546     local $Level = $Level + 1;
547
548     $self->_unoverload_num( \$got, \$expect );
549
550     if( !defined $got || !defined $expect ) {
551         # undef only matches undef and nothing else
552         my $test = !defined $got && !defined $expect;
553
554         $self->ok( $test, $name );
555         $self->_is_diag( $got, '==', $expect ) unless $test;
556         return $test;
557     }
558
559     return $self->cmp_ok( $got, '==', $expect, $name );
560 }
561
562 sub _diag_fmt {
563     my( $self, $type, $val ) = @_;
564
565     if( defined $$val ) {
566         if( $type eq 'eq' or $type eq 'ne' ) {
567             # quote and force string context
568             $$val = "'$$val'";
569         }
570         else {
571             # force numeric context
572             $self->_unoverload_num($val);
573         }
574     }
575     else {
576         $$val = 'undef';
577     }
578
579     return;
580 }
581
582 sub _is_diag {
583     my( $self, $got, $type, $expect ) = @_;
584
585     $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
586
587     local $Level = $Level + 1;
588     return $self->diag(<<"DIAGNOSTIC");
589          got: $got
590     expected: $expect
591 DIAGNOSTIC
592
593 }
594
595 sub _isnt_diag {
596     my( $self, $got, $type ) = @_;
597
598     $self->_diag_fmt( $type, \$got );
599
600     local $Level = $Level + 1;
601     return $self->diag(<<"DIAGNOSTIC");
602          got: $got
603     expected: anything else
604 DIAGNOSTIC
605 }
606
607 =item B<isnt_eq>
608
609   $Test->isnt_eq($got, $dont_expect, $name);
610
611 Like Test::More's isnt().  Checks if $got ne $dont_expect.  This is
612 the string version.
613
614 =item B<isnt_num>
615
616   $Test->isnt_num($got, $dont_expect, $name);
617
618 Like Test::More's isnt().  Checks if $got ne $dont_expect.  This is
619 the numeric version.
620
621 =cut
622
623 sub isnt_eq {
624     my( $self, $got, $dont_expect, $name ) = @_;
625     local $Level = $Level + 1;
626
627     if( !defined $got || !defined $dont_expect ) {
628         # undef only matches undef and nothing else
629         my $test = defined $got || defined $dont_expect;
630
631         $self->ok( $test, $name );
632         $self->_isnt_diag( $got, 'ne' ) unless $test;
633         return $test;
634     }
635
636     return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
637 }
638
639 sub isnt_num {
640     my( $self, $got, $dont_expect, $name ) = @_;
641     local $Level = $Level + 1;
642
643     if( !defined $got || !defined $dont_expect ) {
644         # undef only matches undef and nothing else
645         my $test = defined $got || defined $dont_expect;
646
647         $self->ok( $test, $name );
648         $self->_isnt_diag( $got, '!=' ) unless $test;
649         return $test;
650     }
651
652     return $self->cmp_ok( $got, '!=', $dont_expect, $name );
653 }
654
655 =item B<like>
656
657   $Test->like($this, qr/$regex/, $name);
658   $Test->like($this, '/$regex/', $name);
659
660 Like Test::More's like().  Checks if $this matches the given $regex.
661
662 You'll want to avoid qr// if you want your tests to work before 5.005.
663
664 =item B<unlike>
665
666   $Test->unlike($this, qr/$regex/, $name);
667   $Test->unlike($this, '/$regex/', $name);
668
669 Like Test::More's unlike().  Checks if $this B<does not match> the
670 given $regex.
671
672 =cut
673
674 sub like {
675     my( $self, $this, $regex, $name ) = @_;
676
677     local $Level = $Level + 1;
678     return $self->_regex_ok( $this, $regex, '=~', $name );
679 }
680
681 sub unlike {
682     my( $self, $this, $regex, $name ) = @_;
683
684     local $Level = $Level + 1;
685     return $self->_regex_ok( $this, $regex, '!~', $name );
686 }
687
688 =item B<cmp_ok>
689
690   $Test->cmp_ok($this, $type, $that, $name);
691
692 Works just like Test::More's cmp_ok().
693
694     $Test->cmp_ok($big_num, '!=', $other_big_num);
695
696 =cut
697
698 my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
699
700 sub cmp_ok {
701     my( $self, $got, $type, $expect, $name ) = @_;
702
703     my $test;
704     my $error;
705     {
706         ## no critic (BuiltinFunctions::ProhibitStringyEval)
707
708         local( $@, $!, $SIG{__DIE__} );    # isolate eval
709
710         my($pack, $file, $line) = $self->caller();
711
712         $test = eval qq[
713 #line 1 "cmp_ok [from $file line $line]"
714 \$got $type \$expect;
715 ];
716         $error = $@;
717     }
718     local $Level = $Level + 1;
719     my $ok = $self->ok( $test, $name );
720
721     # Treat overloaded objects as numbers if we're asked to do a
722     # numeric comparison.
723     my $unoverload
724       = $numeric_cmps{$type}
725       ? '_unoverload_num'
726       : '_unoverload_str';
727
728     $self->diag(<<"END") if $error;
729 An error occurred while using $type:
730 ------------------------------------
731 $error
732 ------------------------------------
733 END
734
735     unless($ok) {
736         $self->$unoverload( \$got, \$expect );
737
738         if( $type =~ /^(eq|==)$/ ) {
739             $self->_is_diag( $got, $type, $expect );
740         }
741         elsif( $type =~ /^(ne|!=)$/ ) {
742             $self->_isnt_diag( $got, $type );
743         }
744         else {
745             $self->_cmp_diag( $got, $type, $expect );
746         }
747     }
748     return $ok;
749 }
750
751 sub _cmp_diag {
752     my( $self, $got, $type, $expect ) = @_;
753
754     $got    = defined $got    ? "'$got'"    : 'undef';
755     $expect = defined $expect ? "'$expect'" : 'undef';
756
757     local $Level = $Level + 1;
758     return $self->diag(<<"DIAGNOSTIC");
759     $got
760         $type
761     $expect
762 DIAGNOSTIC
763 }
764
765 sub _caller_context {
766     my $self = shift;
767
768     my( $pack, $file, $line ) = $self->caller(1);
769
770     my $code = '';
771     $code .= "#line $line $file\n" if defined $file and defined $line;
772
773     return $code;
774 }
775
776 =back
777
778
779 =head2 Other Testing Methods
780
781 These are methods which are used in the course of writing a test but are not themselves tests.
782
783 =over 4
784
785 =item B<BAIL_OUT>
786
787     $Test->BAIL_OUT($reason);
788
789 Indicates to the Test::Harness that things are going so badly all
790 testing should terminate.  This includes running any additional test
791 scripts.
792
793 It will exit with 255.
794
795 =cut
796
797 sub BAIL_OUT {
798     my( $self, $reason ) = @_;
799
800     $self->{Bailed_Out} = 1;
801     $self->_print("Bail out!  $reason");
802     exit 255;
803 }
804
805 =for deprecated
806 BAIL_OUT() used to be BAILOUT()
807
808 =cut
809
810 *BAILOUT = \&BAIL_OUT;
811
812 =item B<skip>
813
814     $Test->skip;
815     $Test->skip($why);
816
817 Skips the current test, reporting $why.
818
819 =cut
820
821 sub skip {
822     my( $self, $why ) = @_;
823     $why ||= '';
824     $self->_unoverload_str( \$why );
825
826     $self->_plan_check;
827
828     lock( $self->{Curr_Test} );
829     $self->{Curr_Test}++;
830
831     $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
832         {
833             'ok'      => 1,
834             actual_ok => 1,
835             name      => '',
836             type      => 'skip',
837             reason    => $why,
838         }
839     );
840
841     my $out = "ok";
842     $out .= " $self->{Curr_Test}" if $self->use_numbers;
843     $out .= " # skip";
844     $out .= " $why"               if length $why;
845     $out .= "\n";
846
847     $self->_print($out);
848
849     return 1;
850 }
851
852 =item B<todo_skip>
853
854   $Test->todo_skip;
855   $Test->todo_skip($why);
856
857 Like skip(), only it will declare the test as failing and TODO.  Similar
858 to
859
860     print "not ok $tnum # TODO $why\n";
861
862 =cut
863
864 sub todo_skip {
865     my( $self, $why ) = @_;
866     $why ||= '';
867
868     $self->_plan_check;
869
870     lock( $self->{Curr_Test} );
871     $self->{Curr_Test}++;
872
873     $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
874         {
875             'ok'      => 1,
876             actual_ok => 0,
877             name      => '',
878             type      => 'todo_skip',
879             reason    => $why,
880         }
881     );
882
883     my $out = "not ok";
884     $out .= " $self->{Curr_Test}" if $self->use_numbers;
885     $out .= " # TODO & SKIP $why\n";
886
887     $self->_print($out);
888
889     return 1;
890 }
891
892 =begin _unimplemented
893
894 =item B<skip_rest>
895
896   $Test->skip_rest;
897   $Test->skip_rest($reason);
898
899 Like skip(), only it skips all the rest of the tests you plan to run
900 and terminates the test.
901
902 If you're running under no_plan, it skips once and terminates the
903 test.
904
905 =end _unimplemented
906
907 =back
908
909
910 =head2 Test building utility methods
911
912 These methods are useful when writing your own test methods.
913
914 =over 4
915
916 =item B<maybe_regex>
917
918   $Test->maybe_regex(qr/$regex/);
919   $Test->maybe_regex('/$regex/');
920
921 Convenience method for building testing functions that take regular
922 expressions as arguments, but need to work before perl 5.005.
923
924 Takes a quoted regular expression produced by qr//, or a string
925 representing a regular expression.
926
927 Returns a Perl value which may be used instead of the corresponding
928 regular expression, or undef if its argument is not recognised.
929
930 For example, a version of like(), sans the useful diagnostic messages,
931 could be written as:
932
933   sub laconic_like {
934       my ($self, $this, $regex, $name) = @_;
935       my $usable_regex = $self->maybe_regex($regex);
936       die "expecting regex, found '$regex'\n"
937           unless $usable_regex;
938       $self->ok($this =~ m/$usable_regex/, $name);
939   }
940
941 =cut
942
943 sub maybe_regex {
944     my( $self, $regex ) = @_;
945     my $usable_regex = undef;
946
947     return $usable_regex unless defined $regex;
948
949     my( $re, $opts );
950
951     # Check for qr/foo/
952     if( _is_qr($regex) ) {
953         $usable_regex = $regex;
954     }
955     # Check for '/foo/' or 'm,foo,'
956     elsif(( $re, $opts )        = $regex =~ m{^ /(.*)/ (\w*) $ }sx              or
957           ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
958     )
959     {
960         $usable_regex = length $opts ? "(?$opts)$re" : $re;
961     }
962
963     return $usable_regex;
964 }
965
966 sub _is_qr {
967     my $regex = shift;
968
969     # is_regexp() checks for regexes in a robust manner, say if they're
970     # blessed.
971     return re::is_regexp($regex) if defined &re::is_regexp;
972     return ref $regex eq 'Regexp';
973 }
974
975 sub _regex_ok {
976     my( $self, $this, $regex, $cmp, $name ) = @_;
977
978     my $ok           = 0;
979     my $usable_regex = $self->maybe_regex($regex);
980     unless( defined $usable_regex ) {
981         local $Level = $Level + 1;
982         $ok = $self->ok( 0, $name );
983         $self->diag("    '$regex' doesn't look much like a regex to me.");
984         return $ok;
985     }
986
987     {
988         ## no critic (BuiltinFunctions::ProhibitStringyEval)
989
990         my $test;
991         my $code = $self->_caller_context;
992
993         local( $@, $!, $SIG{__DIE__} );    # isolate eval
994
995         # Yes, it has to look like this or 5.4.5 won't see the #line
996         # directive.
997         # Don't ask me, man, I just work here.
998         $test = eval "
999 $code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
1000
1001         $test = !$test if $cmp eq '!~';
1002
1003         local $Level = $Level + 1;
1004         $ok = $self->ok( $test, $name );
1005     }
1006
1007     unless($ok) {
1008         $this = defined $this ? "'$this'" : 'undef';
1009         my $match = $cmp eq '=~' ? "doesn't match" : "matches";
1010
1011         local $Level = $Level + 1;
1012         $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex );
1013                   %s
1014     %13s '%s'
1015 DIAGNOSTIC
1016
1017     }
1018
1019     return $ok;
1020 }
1021
1022 # I'm not ready to publish this.  It doesn't deal with array return
1023 # values from the code or context.
1024
1025 =begin private
1026
1027 =item B<_try>
1028
1029     my $return_from_code          = $Test->try(sub { code });
1030     my($return_from_code, $error) = $Test->try(sub { code });
1031
1032 Works like eval BLOCK except it ensures it has no effect on the rest
1033 of the test (ie. $@ is not set) nor is effected by outside
1034 interference (ie. $SIG{__DIE__}) and works around some quirks in older
1035 Perls.
1036
1037 $error is what would normally be in $@.
1038
1039 It is suggested you use this in place of eval BLOCK.
1040
1041 =cut
1042
1043 sub _try {
1044     my( $self, $code, %opts ) = @_;
1045
1046     my $error;
1047     my $return;
1048     {
1049         local $!;               # eval can mess up $!
1050         local $@;               # don't set $@ in the test
1051         local $SIG{__DIE__};    # don't trip an outside DIE handler.
1052         $return = eval { $code->() };
1053         $error = $@;
1054     }
1055
1056     die $error if $error and $opts{die_on_fail};
1057
1058     return wantarray ? ( $return, $error ) : $return;
1059 }
1060
1061 =end private
1062
1063
1064 =item B<is_fh>
1065
1066     my $is_fh = $Test->is_fh($thing);
1067
1068 Determines if the given $thing can be used as a filehandle.
1069
1070 =cut
1071
1072 sub is_fh {
1073     my $self     = shift;
1074     my $maybe_fh = shift;
1075     return 0 unless defined $maybe_fh;
1076
1077     return 1 if ref $maybe_fh  eq 'GLOB';    # its a glob ref
1078     return 1 if ref \$maybe_fh eq 'GLOB';    # its a glob
1079
1080     return eval { $maybe_fh->isa("IO::Handle") } ||
1081            # 5.5.4's tied() and can() doesn't like getting undef
1082            eval { ( tied($maybe_fh) || '' )->can('TIEHANDLE') };
1083 }
1084
1085 =back
1086
1087
1088 =head2 Test style
1089
1090
1091 =over 4
1092
1093 =item B<level>
1094
1095     $Test->level($how_high);
1096
1097 How far up the call stack should $Test look when reporting where the
1098 test failed.
1099
1100 Defaults to 1.
1101
1102 Setting L<$Test::Builder::Level> overrides.  This is typically useful
1103 localized:
1104
1105     sub my_ok {
1106         my $test = shift;
1107
1108         local $Test::Builder::Level = $Test::Builder::Level + 1;
1109         $TB->ok($test);
1110     }
1111
1112 To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant.
1113
1114 =cut
1115
1116 sub level {
1117     my( $self, $level ) = @_;
1118
1119     if( defined $level ) {
1120         $Level = $level;
1121     }
1122     return $Level;
1123 }
1124
1125 =item B<use_numbers>
1126
1127     $Test->use_numbers($on_or_off);
1128
1129 Whether or not the test should output numbers.  That is, this if true:
1130
1131   ok 1
1132   ok 2
1133   ok 3
1134
1135 or this if false
1136
1137   ok
1138   ok
1139   ok
1140
1141 Most useful when you can't depend on the test output order, such as
1142 when threads or forking is involved.
1143
1144 Defaults to on.
1145
1146 =cut
1147
1148 sub use_numbers {
1149     my( $self, $use_nums ) = @_;
1150
1151     if( defined $use_nums ) {
1152         $self->{Use_Nums} = $use_nums;
1153     }
1154     return $self->{Use_Nums};
1155 }
1156
1157 =item B<no_diag>
1158
1159     $Test->no_diag($no_diag);
1160
1161 If set true no diagnostics will be printed.  This includes calls to
1162 diag().
1163
1164 =item B<no_ending>
1165
1166     $Test->no_ending($no_ending);
1167
1168 Normally, Test::Builder does some extra diagnostics when the test
1169 ends.  It also changes the exit code as described below.
1170
1171 If this is true, none of that will be done.
1172
1173 =item B<no_header>
1174
1175     $Test->no_header($no_header);
1176
1177 If set to true, no "1..N" header will be printed.
1178
1179 =cut
1180
1181 foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
1182     my $method = lc $attribute;
1183
1184     my $code = sub {
1185         my( $self, $no ) = @_;
1186
1187         if( defined $no ) {
1188             $self->{$attribute} = $no;
1189         }
1190         return $self->{$attribute};
1191     };
1192
1193     no strict 'refs';    ## no critic
1194     *{ __PACKAGE__ . '::' . $method } = $code;
1195 }
1196
1197 =back
1198
1199 =head2 Output
1200
1201 Controlling where the test output goes.
1202
1203 It's ok for your test to change where STDOUT and STDERR point to,
1204 Test::Builder's default output settings will not be affected.
1205
1206 =over 4
1207
1208 =item B<diag>
1209
1210     $Test->diag(@msgs);
1211
1212 Prints out the given @msgs.  Like C<print>, arguments are simply
1213 appended together.
1214
1215 Normally, it uses the failure_output() handle, but if this is for a
1216 TODO test, the todo_output() handle is used.
1217
1218 Output will be indented and marked with a # so as not to interfere
1219 with test output.  A newline will be put on the end if there isn't one
1220 already.
1221
1222 We encourage using this rather than calling print directly.
1223
1224 Returns false.  Why?  Because diag() is often used in conjunction with
1225 a failing test (C<ok() || diag()>) it "passes through" the failure.
1226
1227     return ok(...) || diag(...);
1228
1229 =for blame transfer
1230 Mark Fowler <mark@twoshortplanks.com>
1231
1232 =cut
1233
1234 sub diag {
1235     my $self = shift;
1236
1237     $self->_print_comment( $self->_diag_fh, @_ );
1238 }
1239
1240 =item B<note>
1241
1242     $Test->note(@msgs);
1243
1244 Like diag(), but it prints to the C<output()> handle so it will not
1245 normally be seen by the user except in verbose mode.
1246
1247 =cut
1248
1249 sub note {
1250     my $self = shift;
1251
1252     $self->_print_comment( $self->output, @_ );
1253 }
1254
1255 sub _diag_fh {
1256     my $self = shift;
1257
1258     local $Level = $Level + 1;
1259     return $self->in_todo ? $self->todo_output : $self->failure_output;
1260 }
1261
1262 sub _print_comment {
1263     my( $self, $fh, @msgs ) = @_;
1264
1265     return if $self->no_diag;
1266     return unless @msgs;
1267
1268     # Prevent printing headers when compiling (i.e. -c)
1269     return if $^C;
1270
1271     # Smash args together like print does.
1272     # Convert undef to 'undef' so its readable.
1273     my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1274
1275     # Escape the beginning, _print will take care of the rest.
1276     $msg =~ s/^/# /;
1277
1278     local $Level = $Level + 1;
1279     $self->_print_to_fh( $fh, $msg );
1280
1281     return 0;
1282 }
1283
1284 =item B<explain>
1285
1286     my @dump = $Test->explain(@msgs);
1287
1288 Will dump the contents of any references in a human readable format.
1289 Handy for things like...
1290
1291     is_deeply($have, $want) || diag explain $have;
1292
1293 or
1294
1295     is_deeply($have, $want) || note explain $have;
1296
1297 =cut
1298
1299 sub explain {
1300     my $self = shift;
1301
1302     return map {
1303         ref $_
1304           ? do {
1305             $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
1306
1307             my $dumper = Data::Dumper->new( [$_] );
1308             $dumper->Indent(1)->Terse(1);
1309             $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
1310             $dumper->Dump;
1311           }
1312           : $_
1313     } @_;
1314 }
1315
1316 =begin _private
1317
1318 =item B<_print>
1319
1320     $Test->_print(@msgs);
1321
1322 Prints to the output() filehandle.
1323
1324 =end _private
1325
1326 =cut
1327
1328 sub _print {
1329     my $self = shift;
1330     return $self->_print_to_fh( $self->output, @_ );
1331 }
1332
1333 sub _print_to_fh {
1334     my( $self, $fh, @msgs ) = @_;
1335
1336     # Prevent printing headers when only compiling.  Mostly for when
1337     # tests are deparsed with B::Deparse
1338     return if $^C;
1339
1340     my $msg = join '', @msgs;
1341
1342     local( $\, $", $, ) = ( undef, ' ', '' );
1343
1344     # Escape each line after the first with a # so we don't
1345     # confuse Test::Harness.
1346     $msg =~ s{\n(?!\z)}{\n# }sg;
1347
1348     # Stick a newline on the end if it needs it.
1349     $msg .= "\n" unless $msg =~ /\n\z/;
1350
1351     return print $fh $msg;
1352 }
1353
1354 =item B<output>
1355
1356     $Test->output($fh);
1357     $Test->output($file);
1358
1359 Where normal "ok/not ok" test output should go.
1360
1361 Defaults to STDOUT.
1362
1363 =item B<failure_output>
1364
1365     $Test->failure_output($fh);
1366     $Test->failure_output($file);
1367
1368 Where diagnostic output on test failures and diag() should go.
1369
1370 Defaults to STDERR.
1371
1372 =item B<todo_output>
1373
1374     $Test->todo_output($fh);
1375     $Test->todo_output($file);
1376
1377 Where diagnostics about todo test failures and diag() should go.
1378
1379 Defaults to STDOUT.
1380
1381 =cut
1382
1383 sub output {
1384     my( $self, $fh ) = @_;
1385
1386     if( defined $fh ) {
1387         $self->{Out_FH} = $self->_new_fh($fh);
1388     }
1389     return $self->{Out_FH};
1390 }
1391
1392 sub failure_output {
1393     my( $self, $fh ) = @_;
1394
1395     if( defined $fh ) {
1396         $self->{Fail_FH} = $self->_new_fh($fh);
1397     }
1398     return $self->{Fail_FH};
1399 }
1400
1401 sub todo_output {
1402     my( $self, $fh ) = @_;
1403
1404     if( defined $fh ) {
1405         $self->{Todo_FH} = $self->_new_fh($fh);
1406     }
1407     return $self->{Todo_FH};
1408 }
1409
1410 sub _new_fh {
1411     my $self = shift;
1412     my($file_or_fh) = shift;
1413
1414     my $fh;
1415     if( $self->is_fh($file_or_fh) ) {
1416         $fh = $file_or_fh;
1417     }
1418     else {
1419         open $fh, ">", $file_or_fh
1420           or $self->croak("Can't open test output log $file_or_fh: $!");
1421         _autoflush($fh);
1422     }
1423
1424     return $fh;
1425 }
1426
1427 sub _autoflush {
1428     my($fh) = shift;
1429     my $old_fh = select $fh;
1430     $| = 1;
1431     select $old_fh;
1432
1433     return;
1434 }
1435
1436 my( $Testout, $Testerr );
1437
1438 sub _dup_stdhandles {
1439     my $self = shift;
1440
1441     $self->_open_testhandles;
1442
1443     # Set everything to unbuffered else plain prints to STDOUT will
1444     # come out in the wrong order from our own prints.
1445     _autoflush($Testout);
1446     _autoflush( \*STDOUT );
1447     _autoflush($Testerr);
1448     _autoflush( \*STDERR );
1449
1450     $self->reset_outputs;
1451
1452     return;
1453 }
1454
1455 my $Opened_Testhandles = 0;
1456
1457 sub _open_testhandles {
1458     my $self = shift;
1459
1460     return if $Opened_Testhandles;
1461
1462     # We dup STDOUT and STDERR so people can change them in their
1463     # test suites while still getting normal test output.
1464     open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT:  $!";
1465     open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR:  $!";
1466
1467     #    $self->_copy_io_layers( \*STDOUT, $Testout );
1468     #    $self->_copy_io_layers( \*STDERR, $Testerr );
1469
1470     $Opened_Testhandles = 1;
1471
1472     return;
1473 }
1474
1475 sub _copy_io_layers {
1476     my( $self, $src, $dst ) = @_;
1477
1478     $self->_try(
1479         sub {
1480             require PerlIO;
1481             my @src_layers = PerlIO::get_layers($src);
1482
1483             binmode $dst, join " ", map ":$_", @src_layers if @src_layers;
1484         }
1485     );
1486
1487     return;
1488 }
1489
1490 =item reset_outputs
1491
1492   $tb->reset_outputs;
1493
1494 Resets all the output filehandles back to their defaults.
1495
1496 =cut
1497
1498 sub reset_outputs {
1499     my $self = shift;
1500
1501     $self->output        ($Testout);
1502     $self->failure_output($Testerr);
1503     $self->todo_output   ($Testout);
1504
1505     return;
1506 }
1507
1508 =item carp
1509
1510   $tb->carp(@message);
1511
1512 Warns with C<@message> but the message will appear to come from the
1513 point where the original test function was called (C<$tb->caller>).
1514
1515 =item croak
1516
1517   $tb->croak(@message);
1518
1519 Dies with C<@message> but the message will appear to come from the
1520 point where the original test function was called (C<$tb->caller>).
1521
1522 =cut
1523
1524 sub _message_at_caller {
1525     my $self = shift;
1526
1527     local $Level = $Level + 1;
1528     my( $pack, $file, $line ) = $self->caller;
1529     return join( "", @_ ) . " at $file line $line.\n";
1530 }
1531
1532 sub carp {
1533     my $self = shift;
1534     return warn $self->_message_at_caller(@_);
1535 }
1536
1537 sub croak {
1538     my $self = shift;
1539     return die $self->_message_at_caller(@_);
1540 }
1541
1542 sub _plan_check {
1543     my $self = shift;
1544
1545     unless( $self->{Have_Plan} ) {
1546         local $Level = $Level + 2;
1547         $self->croak("You tried to run a test without a plan");
1548     }
1549
1550     return;
1551 }
1552
1553 =back
1554
1555
1556 =head2 Test Status and Info
1557
1558 =over 4
1559
1560 =item B<current_test>
1561
1562     my $curr_test = $Test->current_test;
1563     $Test->current_test($num);
1564
1565 Gets/sets the current test number we're on.  You usually shouldn't
1566 have to set this.
1567
1568 If set forward, the details of the missing tests are filled in as 'unknown'.
1569 if set backward, the details of the intervening tests are deleted.  You
1570 can erase history if you really want to.
1571
1572 =cut
1573
1574 sub current_test {
1575     my( $self, $num ) = @_;
1576
1577     lock( $self->{Curr_Test} );
1578     if( defined $num ) {
1579         $self->croak("Can't change the current test number without a plan!")
1580           unless $self->{Have_Plan};
1581
1582         $self->{Curr_Test} = $num;
1583
1584         # If the test counter is being pushed forward fill in the details.
1585         my $test_results = $self->{Test_Results};
1586         if( $num > @$test_results ) {
1587             my $start = @$test_results ? @$test_results : 0;
1588             for( $start .. $num - 1 ) {
1589                 $test_results->[$_] = &share(
1590                     {
1591                         'ok'      => 1,
1592                         actual_ok => undef,
1593                         reason    => 'incrementing test number',
1594                         type      => 'unknown',
1595                         name      => undef
1596                     }
1597                 );
1598             }
1599         }
1600         # If backward, wipe history.  Its their funeral.
1601         elsif( $num < @$test_results ) {
1602             $#{$test_results} = $num - 1;
1603         }
1604     }
1605     return $self->{Curr_Test};
1606 }
1607
1608 =item B<summary>
1609
1610     my @tests = $Test->summary;
1611
1612 A simple summary of the tests so far.  True for pass, false for fail.
1613 This is a logical pass/fail, so todos are passes.
1614
1615 Of course, test #1 is $tests[0], etc...
1616
1617 =cut
1618
1619 sub summary {
1620     my($self) = shift;
1621
1622     return map { $_->{'ok'} } @{ $self->{Test_Results} };
1623 }
1624
1625 =item B<details>
1626
1627     my @tests = $Test->details;
1628
1629 Like summary(), but with a lot more detail.
1630
1631     $tests[$test_num - 1] = 
1632             { 'ok'       => is the test considered a pass?
1633               actual_ok  => did it literally say 'ok'?
1634               name       => name of the test (if any)
1635               type       => type of test (if any, see below).
1636               reason     => reason for the above (if any)
1637             };
1638
1639 'ok' is true if Test::Harness will consider the test to be a pass.
1640
1641 'actual_ok' is a reflection of whether or not the test literally
1642 printed 'ok' or 'not ok'.  This is for examining the result of 'todo'
1643 tests.  
1644
1645 'name' is the name of the test.
1646
1647 'type' indicates if it was a special test.  Normal tests have a type
1648 of ''.  Type can be one of the following:
1649
1650     skip        see skip()
1651     todo        see todo()
1652     todo_skip   see todo_skip()
1653     unknown     see below
1654
1655 Sometimes the Test::Builder test counter is incremented without it
1656 printing any test output, for example, when current_test() is changed.
1657 In these cases, Test::Builder doesn't know the result of the test, so
1658 its type is 'unknown'.  These details for these tests are filled in.
1659 They are considered ok, but the name and actual_ok is left undef.
1660
1661 For example "not ok 23 - hole count # TODO insufficient donuts" would
1662 result in this structure:
1663
1664     $tests[22] =    # 23 - 1, since arrays start from 0.
1665       { ok        => 1,   # logically, the test passed since it's todo
1666         actual_ok => 0,   # in absolute terms, it failed
1667         name      => 'hole count',
1668         type      => 'todo',
1669         reason    => 'insufficient donuts'
1670       };
1671
1672 =cut
1673
1674 sub details {
1675     my $self = shift;
1676     return @{ $self->{Test_Results} };
1677 }
1678
1679 =item B<todo>
1680
1681     my $todo_reason = $Test->todo;
1682     my $todo_reason = $Test->todo($pack);
1683
1684 If the current tests are considered "TODO" it will return the reason,
1685 if any.  This reason can come from a $TODO variable or the last call
1686 to C<<todo_start()>>.
1687
1688 Since a TODO test does not need a reason, this function can return an
1689 empty string even when inside a TODO block.  Use C<<$Test->in_todo>>
1690 to determine if you are currently inside a TODO block.
1691
1692 todo() is about finding the right package to look for $TODO in.  It's
1693 pretty good at guessing the right package to look at.  It first looks for
1694 the caller based on C<$Level + 1>, since C<todo()> is usually called inside
1695 a test function.  As a last resort it will use C<exported_to()>.
1696
1697 Sometimes there is some confusion about where todo() should be looking
1698 for the $TODO variable.  If you want to be sure, tell it explicitly
1699 what $pack to use.
1700
1701 =cut
1702
1703 sub todo {
1704     my( $self, $pack ) = @_;
1705
1706     return $self->{Todo} if defined $self->{Todo};
1707
1708     local $Level = $Level + 1;
1709     my $todo = $self->find_TODO($pack);
1710     return $todo if defined $todo;
1711
1712     return '';
1713 }
1714
1715 =item B<find_TODO>
1716
1717     my $todo_reason = $Test->find_TODO();
1718     my $todo_reason = $Test->find_TODO($pack):
1719
1720 Like C<<todo()>> but only returns the value of C<<$TODO>> ignoring
1721 C<<todo_start()>>.
1722
1723 =cut
1724
1725 sub find_TODO {
1726     my( $self, $pack ) = @_;
1727
1728     $pack = $pack || $self->caller(1) || $self->exported_to;
1729     return unless $pack;
1730
1731     no strict 'refs';    ## no critic
1732     return ${ $pack . '::TODO' };
1733 }
1734
1735 =item B<in_todo>
1736
1737     my $in_todo = $Test->in_todo;
1738
1739 Returns true if the test is currently inside a TODO block.
1740
1741 =cut
1742
1743 sub in_todo {
1744     my $self = shift;
1745
1746     local $Level = $Level + 1;
1747     return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
1748 }
1749
1750 =item B<todo_start>
1751
1752     $Test->todo_start();
1753     $Test->todo_start($message);
1754
1755 This method allows you declare all subsequent tests as TODO tests, up until
1756 the C<todo_end> method has been called.
1757
1758 The C<TODO:> and C<$TODO> syntax is generally pretty good about figuring out
1759 whether or not we're in a TODO test.  However, often we find that this is not
1760 possible to determine (such as when we want to use C<$TODO> but
1761 the tests are being executed in other packages which can't be inferred
1762 beforehand).
1763
1764 Note that you can use this to nest "todo" tests
1765
1766  $Test->todo_start('working on this');
1767  # lots of code
1768  $Test->todo_start('working on that');
1769  # more code
1770  $Test->todo_end;
1771  $Test->todo_end;
1772
1773 This is generally not recommended, but large testing systems often have weird
1774 internal needs.
1775
1776 We've tried to make this also work with the TODO: syntax, but it's not
1777 guaranteed and its use is also discouraged:
1778
1779  TODO: {
1780      local $TODO = 'We have work to do!';
1781      $Test->todo_start('working on this');
1782      # lots of code
1783      $Test->todo_start('working on that');
1784      # more code
1785      $Test->todo_end;
1786      $Test->todo_end;
1787  }
1788
1789 Pick one style or another of "TODO" to be on the safe side.
1790
1791 =cut
1792
1793 sub todo_start {
1794     my $self = shift;
1795     my $message = @_ ? shift : '';
1796
1797     $self->{Start_Todo}++;
1798     if( $self->in_todo ) {
1799         push @{ $self->{Todo_Stack} } => $self->todo;
1800     }
1801     $self->{Todo} = $message;
1802
1803     return;
1804 }
1805
1806 =item C<todo_end>
1807
1808  $Test->todo_end;
1809
1810 Stops running tests as "TODO" tests.  This method is fatal if called without a
1811 preceding C<todo_start> method call.
1812
1813 =cut
1814
1815 sub todo_end {
1816     my $self = shift;
1817
1818     if( !$self->{Start_Todo} ) {
1819         $self->croak('todo_end() called without todo_start()');
1820     }
1821
1822     $self->{Start_Todo}--;
1823
1824     if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
1825         $self->{Todo} = pop @{ $self->{Todo_Stack} };
1826     }
1827     else {
1828         delete $self->{Todo};
1829     }
1830
1831     return;
1832 }
1833
1834 =item B<caller>
1835
1836     my $package = $Test->caller;
1837     my($pack, $file, $line) = $Test->caller;
1838     my($pack, $file, $line) = $Test->caller($height);
1839
1840 Like the normal caller(), except it reports according to your level().
1841
1842 C<$height> will be added to the level().
1843
1844 If caller() winds up off the top of the stack it report the highest context.
1845
1846 =cut
1847
1848 sub caller {    ## no critic (Subroutines::ProhibitBuiltinHomonyms)
1849     my( $self, $height ) = @_;
1850     $height ||= 0;
1851
1852     my $level = $self->level + $height + 1;
1853     my @caller;
1854     do {
1855         @caller = CORE::caller( $level );
1856         $level--;
1857     } until @caller;
1858     return wantarray ? @caller : $caller[0];
1859 }
1860
1861 =back
1862
1863 =cut
1864
1865 =begin _private
1866
1867 =over 4
1868
1869 =item B<_sanity_check>
1870
1871   $self->_sanity_check();
1872
1873 Runs a bunch of end of test sanity checks to make sure reality came
1874 through ok.  If anything is wrong it will die with a fairly friendly
1875 error message.
1876
1877 =cut
1878
1879 #'#
1880 sub _sanity_check {
1881     my $self = shift;
1882
1883     $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
1884     $self->_whoa( !$self->{Have_Plan} and $self->{Curr_Test},
1885         'Somehow your tests ran without a plan!' );
1886     $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
1887         'Somehow you got a different number of results than tests ran!' );
1888
1889     return;
1890 }
1891
1892 =item B<_whoa>
1893
1894   $self->_whoa($check, $description);
1895
1896 A sanity check, similar to assert().  If the $check is true, something
1897 has gone horribly wrong.  It will die with the given $description and
1898 a note to contact the author.
1899
1900 =cut
1901
1902 sub _whoa {
1903     my( $self, $check, $desc ) = @_;
1904     if($check) {
1905         local $Level = $Level + 1;
1906         $self->croak(<<"WHOA");
1907 WHOA!  $desc
1908 This should never happen!  Please contact the author immediately!
1909 WHOA
1910     }
1911
1912     return;
1913 }
1914
1915 =item B<_my_exit>
1916
1917   _my_exit($exit_num);
1918
1919 Perl seems to have some trouble with exiting inside an END block.  5.005_03
1920 and 5.6.1 both seem to do odd things.  Instead, this function edits $?
1921 directly.  It should ONLY be called from inside an END block.  It
1922 doesn't actually exit, that's your job.
1923
1924 =cut
1925
1926 sub _my_exit {
1927     $? = $_[0];    ## no critic (Variables::RequireLocalizedPunctuationVars)
1928
1929     return 1;
1930 }
1931
1932 =back
1933
1934 =end _private
1935
1936 =cut
1937
1938 sub _ending {
1939     my $self = shift;
1940
1941     my $real_exit_code = $?;
1942     $self->_sanity_check();
1943
1944     # Don't bother with an ending if this is a forked copy.  Only the parent
1945     # should do the ending.
1946     if( $self->{Original_Pid} != $$ ) {
1947         return;
1948     }
1949
1950     # Exit if plan() was never called.  This is so "require Test::Simple"
1951     # doesn't puke.
1952     if( !$self->{Have_Plan} ) {
1953         return;
1954     }
1955
1956     # Don't do an ending if we bailed out.
1957     if( $self->{Bailed_Out} ) {
1958         return;
1959     }
1960
1961     # Figure out if we passed or failed and print helpful messages.
1962     my $test_results = $self->{Test_Results};
1963     if(@$test_results) {
1964         # The plan?  We have no plan.
1965         if( $self->{No_Plan} ) {
1966             $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
1967             $self->{Expected_Tests} = $self->{Curr_Test};
1968         }
1969
1970         # Auto-extended arrays and elements which aren't explicitly
1971         # filled in with a shared reference will puke under 5.8.0
1972         # ithreads.  So we have to fill them in by hand. :(
1973         my $empty_result = &share( {} );
1974         for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
1975             $test_results->[$idx] = $empty_result
1976               unless defined $test_results->[$idx];
1977         }
1978
1979         my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
1980
1981         my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
1982
1983         if( $num_extra != 0 ) {
1984             my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1985             $self->diag(<<"FAIL");
1986 Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}.
1987 FAIL
1988         }
1989
1990         if($num_failed) {
1991             my $num_tests = $self->{Curr_Test};
1992             my $s = $num_failed == 1 ? '' : 's';
1993
1994             my $qualifier = $num_extra == 0 ? '' : ' run';
1995
1996             $self->diag(<<"FAIL");
1997 Looks like you failed $num_failed test$s of $num_tests$qualifier.
1998 FAIL
1999         }
2000
2001         if($real_exit_code) {
2002             $self->diag(<<"FAIL");
2003 Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
2004 FAIL
2005
2006             _my_exit($real_exit_code) && return;
2007         }
2008
2009         my $exit_code;
2010         if($num_failed) {
2011             $exit_code = $num_failed <= 254 ? $num_failed : 254;
2012         }
2013         elsif( $num_extra != 0 ) {
2014             $exit_code = 255;
2015         }
2016         else {
2017             $exit_code = 0;
2018         }
2019
2020         _my_exit($exit_code) && return;
2021     }
2022     elsif( $self->{Skip_All} ) {
2023         _my_exit(0) && return;
2024     }
2025     elsif($real_exit_code) {
2026         $self->diag(<<"FAIL");
2027 Looks like your test exited with $real_exit_code before it could output anything.
2028 FAIL
2029         _my_exit($real_exit_code) && return;
2030     }
2031     else {
2032         $self->diag("No tests run!\n");
2033         _my_exit(255) && return;
2034     }
2035
2036     $self->_whoa( 1, "We fell off the end of _ending()" );
2037 }
2038
2039 END {
2040     $Test->_ending if defined $Test and !$Test->no_ending;
2041 }
2042
2043 =head1 EXIT CODES
2044
2045 If all your tests passed, Test::Builder will exit with zero (which is
2046 normal).  If anything failed it will exit with how many failed.  If
2047 you run less (or more) tests than you planned, the missing (or extras)
2048 will be considered failures.  If no tests were ever run Test::Builder
2049 will throw a warning and exit with 255.  If the test died, even after
2050 having successfully completed all its tests, it will still be
2051 considered a failure and will exit with 255.
2052
2053 So the exit codes are...
2054
2055     0                   all tests successful
2056     255                 test died or all passed but wrong # of tests run
2057     any other number    how many failed (including missing or extras)
2058
2059 If you fail more than 254 tests, it will be reported as 254.
2060
2061
2062 =head1 THREADS
2063
2064 In perl 5.8.1 and later, Test::Builder is thread-safe.  The test
2065 number is shared amongst all threads.  This means if one thread sets
2066 the test number using current_test() they will all be effected.
2067
2068 While versions earlier than 5.8.1 had threads they contain too many
2069 bugs to support.
2070
2071 Test::Builder is only thread-aware if threads.pm is loaded I<before>
2072 Test::Builder.
2073
2074 =head1 EXAMPLES
2075
2076 CPAN can provide the best examples.  Test::Simple, Test::More,
2077 Test::Exception and Test::Differences all use Test::Builder.
2078
2079 =head1 SEE ALSO
2080
2081 Test::Simple, Test::More, Test::Harness
2082
2083 =head1 AUTHORS
2084
2085 Original code by chromatic, maintained by Michael G Schwern
2086 E<lt>schwern@pobox.comE<gt>
2087
2088 =head1 COPYRIGHT
2089
2090 Copyright 2002-2008 by chromatic E<lt>chromatic@wgz.orgE<gt> and
2091                        Michael G Schwern E<lt>schwern@pobox.comE<gt>.
2092
2093 This program is free software; you can redistribute it and/or 
2094 modify it under the same terms as Perl itself.
2095
2096 See F<http://www.perl.com/perl/misc/Artistic.html>
2097
2098 =cut
2099
2100 1;
2101