This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
06543e696ea9ed7f099122d1d2840b3e1564e80c
[perl5.git] / lib / Test / Builder.pm
1 package Test::Builder;
2
3 use 5.004;
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 use strict;
10 use vars qw($VERSION $CLASS);
11 $VERSION = '0.15';
12 $CLASS = __PACKAGE__;
13
14 my $IsVMS = $^O eq 'VMS';
15
16 use vars qw($Level);
17 my @Test_Results = ();
18 my @Test_Details = ();
19 my($Test_Died) = 0;
20 my($Have_Plan) = 0;
21 my $Curr_Test = 0;
22
23 # Make Test::Builder thread-safe for ithreads.
24 BEGIN {
25     use Config;
26     if( $] >= 5.008 && $Config{useithreads} ) {
27         require threads;
28         require threads::shared;
29         threads::shared->import;
30         share(\$Curr_Test);
31         share(\@Test_Details);
32         share(\@Test_Results);
33     }
34     else {
35         *lock = sub { 0 };
36     }
37 }
38
39
40 =head1 NAME
41
42 Test::Builder - Backend for building test libraries
43
44 =head1 SYNOPSIS
45
46   package My::Test::Module;
47   use Test::Builder;
48   require Exporter;
49   @ISA = qw(Exporter);
50   @EXPORT = qw(ok);
51
52   my $Test = Test::Builder->new;
53   $Test->output('my_logfile');
54
55   sub import {
56       my($self) = shift;
57       my $pack = caller;
58
59       $Test->exported_to($pack);
60       $Test->plan(@_);
61
62       $self->export_to_level(1, $self, 'ok');
63   }
64
65   sub ok {
66       my($test, $name) = @_;
67
68       $Test->ok($test, $name);
69   }
70
71
72 =head1 DESCRIPTION
73
74 Test::Simple and Test::More have proven to be popular testing modules,
75 but they're not always flexible enough.  Test::Builder provides the a
76 building block upon which to write your own test libraries I<which can
77 work together>.
78
79 =head2 Construction
80
81 =over 4
82
83 =item B<new>
84
85   my $Test = Test::Builder->new;
86
87 Returns a Test::Builder object representing the current state of the
88 test.
89
90 Since you only run one test per program, there is B<one and only one>
91 Test::Builder object.  No matter how many times you call new(), you're
92 getting the same object.  (This is called a singleton).
93
94 =cut
95
96 my $Test;
97 sub new {
98     my($class) = shift;
99     $Test ||= bless ['Move along, nothing to see here'], $class;
100     return $Test;
101 }
102
103 =back
104
105 =head2 Setting up tests
106
107 These methods are for setting up tests and declaring how many there
108 are.  You usually only want to call one of these methods.
109
110 =over 4
111
112 =item B<exported_to>
113
114   my $pack = $Test->exported_to;
115   $Test->exported_to($pack);
116
117 Tells Test::Builder what package you exported your functions to.
118 This is important for getting TODO tests right.
119
120 =cut
121
122 my $Exported_To;
123 sub exported_to {
124     my($self, $pack) = @_;
125
126     if( defined $pack ) {
127         $Exported_To = $pack;
128     }
129     return $Exported_To;
130 }
131
132 =item B<plan>
133
134   $Test->plan('no_plan');
135   $Test->plan( skip_all => $reason );
136   $Test->plan( tests => $num_tests );
137
138 A convenient way to set up your tests.  Call this and Test::Builder
139 will print the appropriate headers and take the appropriate actions.
140
141 If you call plan(), don't call any of the other methods below.
142
143 =cut
144
145 sub plan {
146     my($self, $cmd, $arg) = @_;
147
148     return unless $cmd;
149
150     if( $Have_Plan ) {
151         die sprintf "You tried to plan twice!  Second plan at %s line %d\n",
152           ($self->caller)[1,2];
153     }
154
155     if( $cmd eq 'no_plan' ) {
156         $self->no_plan;
157     }
158     elsif( $cmd eq 'skip_all' ) {
159         return $self->skip_all($arg);
160     }
161     elsif( $cmd eq 'tests' ) {
162         if( $arg ) {
163             return $self->expected_tests($arg);
164         }
165         elsif( !defined $arg ) {
166             die "Got an undefined number of tests.  Looks like you tried to ".
167                 "say how many tests you plan to run but made a mistake.\n";
168         }
169         elsif( !$arg ) {
170             die "You said to run 0 tests!  You've got to run something.\n";
171         }
172     }
173     else {
174         require Carp;
175         my @args = grep { defined } ($cmd, $arg);
176         Carp::croak("plan() doesn't understand @args");
177     }
178
179     return 1;
180 }
181
182 =item B<expected_tests>
183
184     my $max = $Test->expected_tests;
185     $Test->expected_tests($max);
186
187 Gets/sets the # of tests we expect this test to run and prints out
188 the appropriate headers.
189
190 =cut
191
192 my $Expected_Tests = 0;
193 sub expected_tests {
194     my($self, $max) = @_;
195
196     if( defined $max ) {
197         $Expected_Tests = $max;
198         $Have_Plan      = 1;
199
200         $self->_print("1..$max\n") unless $self->no_header;
201     }
202     return $Expected_Tests;
203 }
204
205
206 =item B<no_plan>
207
208   $Test->no_plan;
209
210 Declares that this test will run an indeterminate # of tests.
211
212 =cut
213
214 my($No_Plan) = 0;
215 sub no_plan {
216     $No_Plan    = 1;
217     $Have_Plan  = 1;
218 }
219
220 =item B<skip_all>
221
222   $Test->skip_all;
223   $Test->skip_all($reason);
224
225 Skips all the tests, using the given $reason.  Exits immediately with 0.
226
227 =cut
228
229 my $Skip_All = 0;
230 sub skip_all {
231     my($self, $reason) = @_;
232
233     my $out = "1..0";
234     $out .= " # Skip $reason" if $reason;
235     $out .= "\n";
236
237     $Skip_All = 1;
238
239     $self->_print($out) unless $self->no_header;
240     exit(0);
241 }
242
243 =back
244
245 =head2 Running tests
246
247 These actually run the tests, analogous to the functions in
248 Test::More.
249
250 $name is always optional.
251
252 =over 4
253
254 =item B<ok>
255
256   $Test->ok($test, $name);
257
258 Your basic test.  Pass if $test is true, fail if $test is false.  Just
259 like Test::Simple's ok().
260
261 =cut
262
263 sub ok {
264     my($self, $test, $name) = @_;
265
266     unless( $Have_Plan ) {
267         require Carp;
268         Carp::croak("You tried to run a test without a plan!  Gotta have a plan.");
269     }
270
271     lock $Curr_Test;
272     $Curr_Test++;
273
274     $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
275     You named your test '$name'.  You shouldn't use numbers for your test names.
276     Very confusing.
277 ERR
278
279     my($pack, $file, $line) = $self->caller;
280
281     my $todo = $self->todo($pack);
282
283     my $out;
284     unless( $test ) {
285         $out .= "not ";
286         $Test_Results[$Curr_Test-1] = $todo ? 1 : 0;
287     }
288     else {
289         $Test_Results[$Curr_Test-1] = 1;
290     }
291
292     $out .= "ok";
293     $out .= " $Curr_Test" if $self->use_numbers;
294
295     if( defined $name ) {
296         $name =~ s|#|\\#|g;     # # in a name can confuse Test::Harness.
297         $out   .= " - $name";
298     }
299
300     if( $todo ) {
301         my $what_todo = $todo;
302         $out   .= " # TODO $what_todo";
303     }
304
305     $out .= "\n";
306
307     $self->_print($out);
308
309     unless( $test ) {
310         my $msg = $todo ? "Failed (TODO)" : "Failed";
311         $self->diag("    $msg test ($file at line $line)\n");
312     } 
313
314     return $test ? 1 : 0;
315 }
316
317 =item B<is_eq>
318
319   $Test->is_eq($got, $expected, $name);
320
321 Like Test::More's is().  Checks if $got eq $expected.  This is the
322 string version.
323
324 =item B<is_num>
325
326   $Test->is_num($got, $expected, $name);
327
328 Like Test::More's is().  Checks if $got == $expected.  This is the
329 numeric version.
330
331 =cut
332
333 sub is_eq {
334     my($self, $got, $expect, $name) = @_;
335     local $Level = $Level + 1;
336
337     if( !defined $got || !defined $expect ) {
338         # undef only matches undef and nothing else
339         my $test = !defined $got && !defined $expect;
340
341         $self->ok($test, $name);
342         $self->_is_diag($got, 'eq', $expect) unless $test;
343         return $test;
344     }
345
346     return $self->cmp_ok($got, 'eq', $expect, $name);
347 }
348
349 sub is_num {
350     my($self, $got, $expect, $name) = @_;
351     local $Level = $Level + 1;
352
353     if( !defined $got || !defined $expect ) {
354         # undef only matches undef and nothing else
355         my $test = !defined $got && !defined $expect;
356
357         $self->ok($test, $name);
358         $self->_is_diag($got, '==', $expect) unless $test;
359         return $test;
360     }
361
362     return $self->cmp_ok($got, '==', $expect, $name);
363 }
364
365 sub _is_diag {
366     my($self, $got, $type, $expect) = @_;
367
368     foreach my $val (\$got, \$expect) {
369         if( defined $$val ) {
370             if( $type eq 'eq' ) {
371                 # quote and force string context
372                 $$val = "'$$val'"
373             }
374             else {
375                 # force numeric context
376                 $$val = $$val+0;
377             }
378         }
379         else {
380             $$val = 'undef';
381         }
382     }
383
384     return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
385          got: %s
386     expected: %s
387 DIAGNOSTIC
388
389 }    
390
391 =item B<isnt_eq>
392
393   $Test->isnt_eq($got, $dont_expect, $name);
394
395 Like Test::More's isnt().  Checks if $got ne $dont_expect.  This is
396 the string version.
397
398 =item B<isnt_num>
399
400   $Test->is_num($got, $dont_expect, $name);
401
402 Like Test::More's isnt().  Checks if $got ne $dont_expect.  This is
403 the numeric version.
404
405 =cut
406
407 sub isnt_eq {
408     my($self, $got, $dont_expect, $name) = @_;
409     local $Level = $Level + 1;
410
411     if( !defined $got || !defined $dont_expect ) {
412         # undef only matches undef and nothing else
413         my $test = defined $got || defined $dont_expect;
414
415         $self->ok($test, $name);
416         $self->_cmp_diag('ne', $got, $dont_expect) unless $test;
417         return $test;
418     }
419
420     return $self->cmp_ok($got, 'ne', $dont_expect, $name);
421 }
422
423 sub isnt_num {
424     my($self, $got, $dont_expect, $name) = @_;
425     local $Level = $Level + 1;
426
427     if( !defined $got || !defined $dont_expect ) {
428         # undef only matches undef and nothing else
429         my $test = defined $got || defined $dont_expect;
430
431         $self->ok($test, $name);
432         $self->_cmp_diag('!=', $got, $dont_expect) unless $test;
433         return $test;
434     }
435
436     return $self->cmp_ok($got, '!=', $dont_expect, $name);
437 }
438
439
440 =item B<like>
441
442   $Test->like($this, qr/$regex/, $name);
443   $Test->like($this, '/$regex/', $name);
444
445 Like Test::More's like().  Checks if $this matches the given $regex.
446
447 You'll want to avoid qr// if you want your tests to work before 5.005.
448
449 =item B<unlike>
450
451   $Test->unlike($this, qr/$regex/, $name);
452   $Test->unlike($this, '/$regex/', $name);
453
454 Like Test::More's unlike().  Checks if $this B<does not match> the
455 given $regex.
456
457 =cut
458
459 sub like {
460     my($self, $this, $regex, $name) = @_;
461
462     local $Level = $Level + 1;
463     $self->_regex_ok($this, $regex, '=~', $name);
464 }
465
466 sub unlike {
467     my($self, $this, $regex, $name) = @_;
468
469     local $Level = $Level + 1;
470     $self->_regex_ok($this, $regex, '!~', $name);
471 }
472
473 =item B<maybe_regex>
474
475   $Test->maybe_regex(qr/$regex/);
476   $Test->maybe_regex('/$regex/');
477
478 Convenience method for building testing functions that take regular
479 expressions as arguments, but need to work before perl 5.005.
480
481 Takes a quoted regular expression produced by qr//, or a string
482 representing a regular expression.
483
484 Returns a Perl value which may be used instead of the corresponding
485 regular expression, or undef if it's argument is not recognised.
486
487 For example, a version of like(), sans the useful diagnostic messages,
488 could be written as:
489
490   sub laconic_like {
491       my ($self, $this, $regex, $name) = @_;
492       my $usable_regex = $self->maybe_regex($regex);
493       die "expecting regex, found '$regex'\n"
494           unless $usable_regex;
495       $self->ok($this =~ m/$usable_regex/, $name);
496   }
497
498 =cut
499
500
501 sub maybe_regex {
502         my ($self, $regex) = @_;
503     my $usable_regex = undef;
504     if( ref $regex eq 'Regexp' ) {
505         $usable_regex = $regex;
506     }
507     # Check if it looks like '/foo/'
508     elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) {
509         $usable_regex = length $opts ? "(?$opts)$re" : $re;
510     };
511     return($usable_regex)
512 };
513
514 sub _regex_ok {
515     my($self, $this, $regex, $cmp, $name) = @_;
516
517     local $Level = $Level + 1;
518
519     my $ok = 0;
520     my $usable_regex = $self->maybe_regex($regex);
521     unless (defined $usable_regex) {
522         $ok = $self->ok( 0, $name );
523         $self->diag("    '$regex' doesn't look much like a regex to me.");
524         return $ok;
525     }
526
527     {
528         local $^W = 0;
529         my $test = $this =~ /$usable_regex/ ? 1 : 0;
530         $test = !$test if $cmp eq '!~';
531         $ok = $self->ok( $test, $name );
532     }
533
534     unless( $ok ) {
535         $this = defined $this ? "'$this'" : 'undef';
536         my $match = $cmp eq '=~' ? "doesn't match" : "matches";
537         $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
538                   %s
539     %13s '%s'
540 DIAGNOSTIC
541
542     }
543
544     return $ok;
545 }
546
547 =item B<cmp_ok>
548
549   $Test->cmp_ok($this, $type, $that, $name);
550
551 Works just like Test::More's cmp_ok().
552
553     $Test->cmp_ok($big_num, '!=', $other_big_num);
554
555 =cut
556
557 sub cmp_ok {
558     my($self, $got, $type, $expect, $name) = @_;
559
560     my $test;
561     {
562         local $^W = 0;
563         local($@,$!);   # don't interfere with $@
564                         # eval() sometimes resets $!
565         $test = eval "\$got $type \$expect";
566     }
567     local $Level = $Level + 1;
568     my $ok = $self->ok($test, $name);
569
570     unless( $ok ) {
571         if( $type =~ /^(eq|==)$/ ) {
572             $self->_is_diag($got, $type, $expect);
573         }
574         else {
575             $self->_cmp_diag($got, $type, $expect);
576         }
577     }
578     return $ok;
579 }
580
581 sub _cmp_diag {
582     my($self, $got, $type, $expect) = @_;
583     
584     $got    = defined $got    ? "'$got'"    : 'undef';
585     $expect = defined $expect ? "'$expect'" : 'undef';
586     return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
587     %s
588         %s
589     %s
590 DIAGNOSTIC
591 }
592
593 =item B<BAILOUT>
594
595     $Test->BAILOUT($reason);
596
597 Indicates to the Test::Harness that things are going so badly all
598 testing should terminate.  This includes running any additional test
599 scripts.
600
601 It will exit with 255.
602
603 =cut
604
605 sub BAILOUT {
606     my($self, $reason) = @_;
607
608     $self->_print("Bail out!  $reason");
609     exit 255;
610 }
611
612 =item B<skip>
613
614     $Test->skip;
615     $Test->skip($why);
616
617 Skips the current test, reporting $why.
618
619 =cut
620
621 sub skip {
622     my($self, $why) = @_;
623     $why ||= '';
624
625     unless( $Have_Plan ) {
626         require Carp;
627         Carp::croak("You tried to run tests without a plan!  Gotta have a plan.");
628     }
629
630     lock($Curr_Test);
631     $Curr_Test++;
632
633     $Test_Results[$Curr_Test-1] = 1;
634
635     my $out = "ok";
636     $out   .= " $Curr_Test" if $self->use_numbers;
637     $out   .= " # skip $why\n";
638
639     $Test->_print($out);
640
641     return 1;
642 }
643
644
645 =item B<todo_skip>
646
647   $Test->todo_skip;
648   $Test->todo_skip($why);
649
650 Like skip(), only it will declare the test as failing and TODO.  Similar
651 to
652
653     print "not ok $tnum # TODO $why\n";
654
655 =cut
656
657 sub todo_skip {
658     my($self, $why) = @_;
659     $why ||= '';
660
661     unless( $Have_Plan ) {
662         require Carp;
663         Carp::croak("You tried to run tests without a plan!  Gotta have a plan.");
664     }
665
666     lock($Curr_Test);
667     $Curr_Test++;
668
669     $Test_Results[$Curr_Test-1] = 1;
670
671     my $out = "not ok";
672     $out   .= " $Curr_Test" if $self->use_numbers;
673     $out   .= " # TODO & SKIP $why\n";
674
675     $Test->_print($out);
676
677     return 1;
678 }
679
680
681 =begin _unimplemented
682
683 =item B<skip_rest>
684
685   $Test->skip_rest;
686   $Test->skip_rest($reason);
687
688 Like skip(), only it skips all the rest of the tests you plan to run
689 and terminates the test.
690
691 If you're running under no_plan, it skips once and terminates the
692 test.
693
694 =end _unimplemented
695
696 =back
697
698
699 =head2 Test style
700
701 =over 4
702
703 =item B<level>
704
705     $Test->level($how_high);
706
707 How far up the call stack should $Test look when reporting where the
708 test failed.
709
710 Defaults to 1.
711
712 Setting $Test::Builder::Level overrides.  This is typically useful
713 localized:
714
715     {
716         local $Test::Builder::Level = 2;
717         $Test->ok($test);
718     }
719
720 =cut
721
722 sub level {
723     my($self, $level) = @_;
724
725     if( defined $level ) {
726         $Level = $level;
727     }
728     return $Level;
729 }
730
731 $CLASS->level(1);
732
733
734 =item B<use_numbers>
735
736     $Test->use_numbers($on_or_off);
737
738 Whether or not the test should output numbers.  That is, this if true:
739
740   ok 1
741   ok 2
742   ok 3
743
744 or this if false
745
746   ok
747   ok
748   ok
749
750 Most useful when you can't depend on the test output order, such as
751 when threads or forking is involved.
752
753 Test::Harness will accept either, but avoid mixing the two styles.
754
755 Defaults to on.
756
757 =cut
758
759 my $Use_Nums = 1;
760 sub use_numbers {
761     my($self, $use_nums) = @_;
762
763     if( defined $use_nums ) {
764         $Use_Nums = $use_nums;
765     }
766     return $Use_Nums;
767 }
768
769 =item B<no_header>
770
771     $Test->no_header($no_header);
772
773 If set to true, no "1..N" header will be printed.
774
775 =item B<no_ending>
776
777     $Test->no_ending($no_ending);
778
779 Normally, Test::Builder does some extra diagnostics when the test
780 ends.  It also changes the exit code as described in Test::Simple.
781
782 If this is true, none of that will be done.
783
784 =cut
785
786 my($No_Header, $No_Ending) = (0,0);
787 sub no_header {
788     my($self, $no_header) = @_;
789
790     if( defined $no_header ) {
791         $No_Header = $no_header;
792     }
793     return $No_Header;
794 }
795
796 sub no_ending {
797     my($self, $no_ending) = @_;
798
799     if( defined $no_ending ) {
800         $No_Ending = $no_ending;
801     }
802     return $No_Ending;
803 }
804
805
806 =back
807
808 =head2 Output
809
810 Controlling where the test output goes.
811
812 It's ok for your test to change where STDOUT and STDERR point to,
813 Test::Builder's default output settings will not be affected.
814
815 =over 4
816
817 =item B<diag>
818
819     $Test->diag(@msgs);
820
821 Prints out the given $message.  Normally, it uses the failure_output()
822 handle, but if this is for a TODO test, the todo_output() handle is
823 used.
824
825 Output will be indented and marked with a # so as not to interfere
826 with test output.  A newline will be put on the end if there isn't one
827 already.
828
829 We encourage using this rather than calling print directly.
830
831 Returns false.  Why?  Because diag() is often used in conjunction with
832 a failing test (C<ok() || diag()>) it "passes through" the failure.
833
834     return ok(...) || diag(...);
835
836 =for blame transfer
837 Mark Fowler <mark@twoshortplanks.com>
838
839 =cut
840
841 sub diag {
842     my($self, @msgs) = @_;
843     return unless @msgs;
844
845     # Prevent printing headers when compiling (i.e. -c)
846     return if $^C;
847
848     # Escape each line with a #.
849     foreach (@msgs) {
850         $_ = 'undef' unless defined;
851         s/^/# /gms;
852     }
853
854     push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
855
856     local $Level = $Level + 1;
857     my $fh = $self->todo ? $self->todo_output : $self->failure_output;
858     local($\, $", $,) = (undef, ' ', '');
859     print $fh @msgs;
860
861     return 0;
862 }
863
864 =begin _private
865
866 =item B<_print>
867
868     $Test->_print(@msgs);
869
870 Prints to the output() filehandle.
871
872 =end _private
873
874 =cut
875
876 sub _print {
877     my($self, @msgs) = @_;
878
879     # Prevent printing headers when only compiling.  Mostly for when
880     # tests are deparsed with B::Deparse
881     return if $^C;
882
883     local($\, $", $,) = (undef, ' ', '');
884     my $fh = $self->output;
885
886     # Escape each line after the first with a # so we don't
887     # confuse Test::Harness.
888     foreach (@msgs) {
889         s/\n(.)/\n# $1/sg;
890     }
891
892     push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
893
894     print $fh @msgs;
895 }
896
897
898 =item B<output>
899
900     $Test->output($fh);
901     $Test->output($file);
902
903 Where normal "ok/not ok" test output should go.
904
905 Defaults to STDOUT.
906
907 =item B<failure_output>
908
909     $Test->failure_output($fh);
910     $Test->failure_output($file);
911
912 Where diagnostic output on test failures and diag() should go.
913
914 Defaults to STDERR.
915
916 =item B<todo_output>
917
918     $Test->todo_output($fh);
919     $Test->todo_output($file);
920
921 Where diagnostics about todo test failures and diag() should go.
922
923 Defaults to STDOUT.
924
925 =cut
926
927 my($Out_FH, $Fail_FH, $Todo_FH);
928 sub output {
929     my($self, $fh) = @_;
930
931     if( defined $fh ) {
932         $Out_FH = _new_fh($fh);
933     }
934     return $Out_FH;
935 }
936
937 sub failure_output {
938     my($self, $fh) = @_;
939
940     if( defined $fh ) {
941         $Fail_FH = _new_fh($fh);
942     }
943     return $Fail_FH;
944 }
945
946 sub todo_output {
947     my($self, $fh) = @_;
948
949     if( defined $fh ) {
950         $Todo_FH = _new_fh($fh);
951     }
952     return $Todo_FH;
953 }
954
955 sub _new_fh {
956     my($file_or_fh) = shift;
957
958     my $fh;
959     unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) {
960         $fh = do { local *FH };
961         open $fh, ">$file_or_fh" or 
962             die "Can't open test output log $file_or_fh: $!";
963     }
964     else {
965         $fh = $file_or_fh;
966     }
967
968     return $fh;
969 }
970
971 unless( $^C ) {
972     # We dup STDOUT and STDERR so people can change them in their
973     # test suites while still getting normal test output.
974     open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT:  $!";
975     open(TESTERR, ">&STDERR") or die "Can't dup STDERR:  $!";
976
977     # Set everything to unbuffered else plain prints to STDOUT will
978     # come out in the wrong order from our own prints.
979     _autoflush(\*TESTOUT);
980     _autoflush(\*STDOUT);
981     _autoflush(\*TESTERR);
982     _autoflush(\*STDERR);
983
984     $CLASS->output(\*TESTOUT);
985     $CLASS->failure_output(\*TESTERR);
986     $CLASS->todo_output(\*TESTOUT);
987 }
988
989 sub _autoflush {
990     my($fh) = shift;
991     my $old_fh = select $fh;
992     $| = 1;
993     select $old_fh;
994 }
995
996
997 =back
998
999
1000 =head2 Test Status and Info
1001
1002 =over 4
1003
1004 =item B<current_test>
1005
1006     my $curr_test = $Test->current_test;
1007     $Test->current_test($num);
1008
1009 Gets/sets the current test # we're on.
1010
1011 You usually shouldn't have to set this.
1012
1013 =cut
1014
1015 sub current_test {
1016     my($self, $num) = @_;
1017
1018     lock($Curr_Test);
1019     if( defined $num ) {
1020         unless( $Have_Plan ) {
1021             require Carp;
1022             Carp::croak("Can't change the current test number without a plan!");
1023         }
1024
1025         $Curr_Test = $num;
1026         if( $num > @Test_Results ) {
1027             my $start = @Test_Results ? $#Test_Results : 0;
1028             for ($start..$num-1) {
1029                 $Test_Results[$_] = 1;
1030             }
1031         }
1032     }
1033     return $Curr_Test;
1034 }
1035
1036
1037 =item B<summary>
1038
1039     my @tests = $Test->summary;
1040
1041 A simple summary of the tests so far.  True for pass, false for fail.
1042 This is a logical pass/fail, so todos are passes.
1043
1044 Of course, test #1 is $tests[0], etc...
1045
1046 =cut
1047
1048 sub summary {
1049     my($self) = shift;
1050
1051     return @Test_Results;
1052 }
1053
1054 =item B<details>  I<UNIMPLEMENTED>
1055
1056     my @tests = $Test->details;
1057
1058 Like summary(), but with a lot more detail.
1059
1060     $tests[$test_num - 1] = 
1061             { ok         => is the test considered ok?
1062               actual_ok  => did it literally say 'ok'?
1063               name       => name of the test (if any)
1064               type       => 'skip' or 'todo' (if any)
1065               reason     => reason for the above (if any)
1066             };
1067
1068 =item B<todo>
1069
1070     my $todo_reason = $Test->todo;
1071     my $todo_reason = $Test->todo($pack);
1072
1073 todo() looks for a $TODO variable in your tests.  If set, all tests
1074 will be considered 'todo' (see Test::More and Test::Harness for
1075 details).  Returns the reason (ie. the value of $TODO) if running as
1076 todo tests, false otherwise.
1077
1078 todo() is pretty part about finding the right package to look for
1079 $TODO in.  It uses the exported_to() package to find it.  If that's
1080 not set, it's pretty good at guessing the right package to look at.
1081
1082 Sometimes there is some confusion about where todo() should be looking
1083 for the $TODO variable.  If you want to be sure, tell it explicitly
1084 what $pack to use.
1085
1086 =cut
1087
1088 sub todo {
1089     my($self, $pack) = @_;
1090
1091     $pack = $pack || $self->exported_to || $self->caller(1);
1092
1093     no strict 'refs';
1094     return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
1095                                      : 0;
1096 }
1097
1098 =item B<caller>
1099
1100     my $package = $Test->caller;
1101     my($pack, $file, $line) = $Test->caller;
1102     my($pack, $file, $line) = $Test->caller($height);
1103
1104 Like the normal caller(), except it reports according to your level().
1105
1106 =cut
1107
1108 sub caller {
1109     my($self, $height) = @_;
1110     $height ||= 0;
1111
1112     my @caller = CORE::caller($self->level + $height + 1);
1113     return wantarray ? @caller : $caller[0];
1114 }
1115
1116 =back
1117
1118 =cut
1119
1120 =begin _private
1121
1122 =over 4
1123
1124 =item B<_sanity_check>
1125
1126   _sanity_check();
1127
1128 Runs a bunch of end of test sanity checks to make sure reality came
1129 through ok.  If anything is wrong it will die with a fairly friendly
1130 error message.
1131
1132 =cut
1133
1134 #'#
1135 sub _sanity_check {
1136     _whoa($Curr_Test < 0,  'Says here you ran a negative number of tests!');
1137     _whoa(!$Have_Plan and $Curr_Test, 
1138           'Somehow your tests ran without a plan!');
1139     _whoa($Curr_Test != @Test_Results,
1140           'Somehow you got a different number of results than tests ran!');
1141 }
1142
1143 =item B<_whoa>
1144
1145   _whoa($check, $description);
1146
1147 A sanity check, similar to assert().  If the $check is true, something
1148 has gone horribly wrong.  It will die with the given $description and
1149 a note to contact the author.
1150
1151 =cut
1152
1153 sub _whoa {
1154     my($check, $desc) = @_;
1155     if( $check ) {
1156         die <<WHOA;
1157 WHOA!  $desc
1158 This should never happen!  Please contact the author immediately!
1159 WHOA
1160     }
1161 }
1162
1163 =item B<_my_exit>
1164
1165   _my_exit($exit_num);
1166
1167 Perl seems to have some trouble with exiting inside an END block.  5.005_03
1168 and 5.6.1 both seem to do odd things.  Instead, this function edits $?
1169 directly.  It should ONLY be called from inside an END block.  It
1170 doesn't actually exit, that's your job.
1171
1172 =cut
1173
1174 sub _my_exit {
1175     $? = $_[0];
1176
1177     return 1;
1178 }
1179
1180
1181 =back
1182
1183 =end _private
1184
1185 =cut
1186
1187 $SIG{__DIE__} = sub {
1188     # We don't want to muck with death in an eval, but $^S isn't
1189     # totally reliable.  5.005_03 and 5.6.1 both do the wrong thing
1190     # with it.  Instead, we use caller.  This also means it runs under
1191     # 5.004!
1192     my $in_eval = 0;
1193     for( my $stack = 1;  my $sub = (CORE::caller($stack))[3];  $stack++ ) {
1194         $in_eval = 1 if $sub =~ /^\(eval\)/;
1195     }
1196     $Test_Died = 1 unless $in_eval;
1197 };
1198
1199 sub _ending {
1200     my $self = shift;
1201
1202     _sanity_check();
1203
1204     # Bailout if plan() was never called.  This is so
1205     # "require Test::Simple" doesn't puke.
1206     do{ _my_exit(0) && return } if !$Have_Plan;
1207
1208     # Figure out if we passed or failed and print helpful messages.
1209     if( @Test_Results ) {
1210         # The plan?  We have no plan.
1211         if( $No_Plan ) {
1212             $self->_print("1..$Curr_Test\n") unless $self->no_header;
1213             $Expected_Tests = $Curr_Test;
1214         }
1215
1216         # 5.8.0 threads bug.  Shared arrays will not be auto-extended 
1217         # by a slice.
1218         $Test_Results[$Expected_Tests-1] = undef
1219           unless defined $Test_Results[$Expected_Tests-1];
1220
1221         my $num_failed = grep !$_, @Test_Results[0..$Expected_Tests-1];
1222         $num_failed += abs($Expected_Tests - @Test_Results);
1223
1224         if( $Curr_Test < $Expected_Tests ) {
1225             $self->diag(<<"FAIL");
1226 Looks like you planned $Expected_Tests tests but only ran $Curr_Test.
1227 FAIL
1228         }
1229         elsif( $Curr_Test > $Expected_Tests ) {
1230             my $num_extra = $Curr_Test - $Expected_Tests;
1231             $self->diag(<<"FAIL");
1232 Looks like you planned $Expected_Tests tests but ran $num_extra extra.
1233 FAIL
1234         }
1235         elsif ( $num_failed ) {
1236             $self->diag(<<"FAIL");
1237 Looks like you failed $num_failed tests of $Expected_Tests.
1238 FAIL
1239         }
1240
1241         if( $Test_Died ) {
1242             $self->diag(<<"FAIL");
1243 Looks like your test died just after $Curr_Test.
1244 FAIL
1245
1246             _my_exit( 255 ) && return;
1247         }
1248
1249         _my_exit( $num_failed <= 254 ? $num_failed : 254  ) && return;
1250     }
1251     elsif ( $Skip_All ) {
1252         _my_exit( 0 ) && return;
1253     }
1254     else {
1255         $self->diag("No tests run!\n");
1256         _my_exit( 255 ) && return;
1257     }
1258 }
1259
1260 END {
1261     $Test->_ending if defined $Test and !$Test->no_ending;
1262 }
1263
1264 =head1 THREADS
1265
1266 In perl 5.8.0 and later, Test::Builder is thread-safe.  The test
1267 number is shared amongst all threads.  This means if one thread sets
1268 the test number using current_test() they will all be effected.
1269
1270 =head1 EXAMPLES
1271
1272 CPAN can provide the best examples.  Test::Simple, Test::More,
1273 Test::Exception and Test::Differences all use Test::Builder.
1274
1275 =head1 SEE ALSO
1276
1277 Test::Simple, Test::More, Test::Harness
1278
1279 =head1 AUTHORS
1280
1281 Original code by chromatic, maintained by Michael G Schwern
1282 E<lt>schwern@pobox.comE<gt>
1283
1284 =head1 COPYRIGHT
1285
1286 Copyright 2001 by chromatic E<lt>chromatic@wgz.orgE<gt>,
1287                   Michael G Schwern E<lt>schwern@pobox.comE<gt>.
1288
1289 This program is free software; you can redistribute it and/or 
1290 modify it under the same terms as Perl itself.
1291
1292 See F<http://www.perl.com/perl/misc/Artistic.html>
1293
1294 =cut
1295
1296 1;