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