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