This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update Test-Simple to CPAN version 1.001006
[perl5.git] / cpan / Test-Simple / lib / Test / Builder.pm
1 package Test::Builder;
2
3 use 5.006;
4 use strict;
5 use warnings;
6
7 our $VERSION = '1.001006';
8 $VERSION = eval $VERSION;    ## no critic (BuiltinFunctions::ProhibitStringyEval)
9
10 BEGIN {
11     if( $] < 5.008 ) {
12         require Test::Builder::IO::Scalar;
13     }
14 }
15
16
17 # Make Test::Builder thread-safe for ithreads.
18 BEGIN {
19     use Config;
20     # Load threads::shared when threads are turned on.
21     # 5.8.0's threads are so busted we no longer support them.
22     if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
23         require threads::shared;
24
25         # Hack around YET ANOTHER threads::shared bug.  It would
26         # occasionally forget the contents of the variable when sharing it.
27         # So we first copy the data, then share, then put our copy back.
28         *share = sub (\[$@%]) {
29             my $type = ref $_[0];
30             my $data;
31
32             if( $type eq 'HASH' ) {
33                 %$data = %{ $_[0] };
34             }
35             elsif( $type eq 'ARRAY' ) {
36                 @$data = @{ $_[0] };
37             }
38             elsif( $type eq 'SCALAR' ) {
39                 $$data = ${ $_[0] };
40             }
41             else {
42                 die( "Unknown type: " . $type );
43             }
44
45             $_[0] = &threads::shared::share( $_[0] );
46
47             if( $type eq 'HASH' ) {
48                 %{ $_[0] } = %$data;
49             }
50             elsif( $type eq 'ARRAY' ) {
51                 @{ $_[0] } = @$data;
52             }
53             elsif( $type eq 'SCALAR' ) {
54                 ${ $_[0] } = $$data;
55             }
56             else {
57                 die( "Unknown type: " . $type );
58             }
59
60             return $_[0];
61         };
62     }
63     # 5.8.0's threads::shared is busted when threads are off
64     # and earlier Perls just don't have that module at all.
65     else {
66         *share = sub { return $_[0] };
67         *lock  = sub { 0 };
68     }
69 }
70
71 =head1 NAME
72
73 Test::Builder - Backend for building test libraries
74
75 =head1 SYNOPSIS
76
77   package My::Test::Module;
78   use base 'Test::Builder::Module';
79
80   my $CLASS = __PACKAGE__;
81
82   sub ok {
83       my($test, $name) = @_;
84       my $tb = $CLASS->builder;
85
86       $tb->ok($test, $name);
87   }
88
89
90 =head1 DESCRIPTION
91
92 L<Test::Simple> and L<Test::More> have proven to be popular testing modules,
93 but they're not always flexible enough.  Test::Builder provides a
94 building block upon which to write your own test libraries I<which can
95 work together>.
96
97 =head2 Construction
98
99 =over 4
100
101 =item B<new>
102
103   my $Test = Test::Builder->new;
104
105 Returns a Test::Builder object representing the current state of the
106 test.
107
108 Since you only run one test per program C<new> always returns the same
109 Test::Builder object.  No matter how many times you call C<new()>, you're
110 getting the same object.  This is called a singleton.  This is done so that
111 multiple modules share such global information as the test counter and
112 where test output is going.
113
114 If you want a completely new Test::Builder object different from the
115 singleton, use C<create>.
116
117 =cut
118
119 our $Test = Test::Builder->new;
120
121 sub new {
122     my($class) = shift;
123     $Test ||= $class->create;
124     return $Test;
125 }
126
127 =item B<create>
128
129   my $Test = Test::Builder->create;
130
131 Ok, so there can be more than one Test::Builder object and this is how
132 you get it.  You might use this instead of C<new()> if you're testing
133 a Test::Builder based module, but otherwise you probably want C<new>.
134
135 B<NOTE>: the implementation is not complete.  C<level>, for example, is
136 still shared amongst B<all> Test::Builder objects, even ones created using
137 this method.  Also, the method name may change in the future.
138
139 =cut
140
141 sub create {
142     my $class = shift;
143
144     my $self = bless {}, $class;
145     $self->reset;
146
147     return $self;
148 }
149
150
151 # Copy an object, currently a shallow.
152 # This does *not* bless the destination.  This keeps the destructor from
153 # firing when we're just storing a copy of the object to restore later.
154 sub _copy {
155     my($src, $dest) = @_;
156
157     %$dest = %$src;
158     _share_keys($dest);
159
160     return;
161 }
162
163
164 =item B<child>
165
166   my $child = $builder->child($name_of_child);
167   $child->plan( tests => 4 );
168   $child->ok(some_code());
169   ...
170   $child->finalize;
171
172 Returns a new instance of C<Test::Builder>.  Any output from this child will
173 be indented four spaces more than the parent's indentation.  When done, the
174 C<finalize> method I<must> be called explicitly.
175
176 Trying to create a new child with a previous child still active (i.e.,
177 C<finalize> not called) will C<croak>.
178
179 Trying to run a test when you have an open child will also C<croak> and cause
180 the test suite to fail.
181
182 =cut
183
184 sub child {
185     my( $self, $name ) = @_;
186
187     if( $self->{Child_Name} ) {
188         $self->croak("You already have a child named ($self->{Child_Name}) running");
189     }
190
191     my $parent_in_todo = $self->in_todo;
192
193     # Clear $TODO for the child.
194     my $orig_TODO = $self->find_TODO(undef, 1, undef);
195
196     my $class = ref $self;
197     my $child = $class->create;
198
199     # Add to our indentation
200     $child->_indent( $self->_indent . '    ' );
201
202     # Make the child use the same outputs as the parent
203     for my $method (qw(output failure_output todo_output)) {
204         $child->$method( $self->$method );
205     }
206
207     # Ensure the child understands if they're inside a TODO
208     if( $parent_in_todo ) {
209         $child->failure_output( $self->todo_output );
210     }
211
212     # This will be reset in finalize. We do this here lest one child failure
213     # cause all children to fail.
214     $child->{Child_Error} = $?;
215     $?                    = 0;
216     $child->{Parent}      = $self;
217     $child->{Parent_TODO} = $orig_TODO;
218     $child->{Name}        = $name || "Child of " . $self->name;
219     $self->{Child_Name}   = $child->name;
220     return $child;
221 }
222
223
224 =item B<subtest>
225
226     $builder->subtest($name, \&subtests, @args);
227
228 See documentation of C<subtest> in Test::More.  
229
230 C<subtest> also, and optionally, accepts arguments which will be passed to the
231 subtests reference.
232
233 =cut
234
235 sub subtest {
236     my $self = shift;
237     my($name, $subtests, @args) = @_;
238
239     if ('CODE' ne ref $subtests) {
240         $self->croak("subtest()'s second argument must be a code ref");
241     }
242
243     # Turn the child into the parent so anyone who has stored a copy of
244     # the Test::Builder singleton will get the child.
245     my $error;
246     my $child;
247     my $parent = {};
248     {
249         # child() calls reset() which sets $Level to 1, so we localize
250         # $Level first to limit the scope of the reset to the subtest.
251         local $Test::Builder::Level = $Test::Builder::Level + 1;
252
253         # Store the guts of $self as $parent and turn $child into $self.
254         $child  = $self->child($name);
255         _copy($self,  $parent);
256         _copy($child, $self);
257
258         my $run_the_subtests = sub {
259             # Add subtest name for clarification of starting point
260             $self->note("Subtest: $name");
261             $subtests->(@args);
262             $self->done_testing unless $self->_plan_handled;
263             1;
264         };
265
266         if( !eval { $run_the_subtests->() } ) {
267             $error = $@;
268         }
269     }
270
271     # Restore the parent and the copied child.
272     _copy($self,   $child);
273     _copy($parent, $self);
274
275     # Restore the parent's $TODO
276     $self->find_TODO(undef, 1, $child->{Parent_TODO});
277
278     # Die *after* we restore the parent.
279     die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
280
281     local $Test::Builder::Level = $Test::Builder::Level + 1;
282     my $finalize = $child->finalize;
283
284     $self->BAIL_OUT($child->{Bailed_Out_Reason}) if $child->{Bailed_Out};
285
286     return $finalize;
287 }
288
289 =begin _private
290
291 =item B<_plan_handled>
292
293     if ( $Test->_plan_handled ) { ... }
294
295 Returns true if the developer has explicitly handled the plan via:
296
297 =over 4
298
299 =item * Explicitly setting the number of tests
300
301 =item * Setting 'no_plan'
302
303 =item * Set 'skip_all'.
304
305 =back
306
307 This is currently used in subtests when we implicitly call C<< $Test->done_testing >>
308 if the developer has not set a plan.
309
310 =end _private
311
312 =cut
313
314 sub _plan_handled {
315     my $self = shift;
316     return $self->{Have_Plan} || $self->{No_Plan} || $self->{Skip_All};
317 }
318
319
320 =item B<finalize>
321
322   my $ok = $child->finalize;
323
324 When your child is done running tests, you must call C<finalize> to clean up
325 and tell the parent your pass/fail status.
326
327 Calling C<finalize> on a child with open children will C<croak>.
328
329 If the child falls out of scope before C<finalize> is called, a failure
330 diagnostic will be issued and the child is considered to have failed.
331
332 No attempt to call methods on a child after C<finalize> is called is
333 guaranteed to succeed.
334
335 Calling this on the root builder is a no-op.
336
337 =cut
338
339 sub finalize {
340     my $self = shift;
341
342     return unless $self->parent;
343     if( $self->{Child_Name} ) {
344         $self->croak("Can't call finalize() with child ($self->{Child_Name}) active");
345     }
346
347     local $? = 0;     # don't fail if $subtests happened to set $? nonzero
348     $self->_ending;
349
350     # XXX This will only be necessary for TAP envelopes (we think)
351     #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );
352
353     local $Test::Builder::Level = $Test::Builder::Level + 1;
354     my $ok = 1;
355     $self->parent->{Child_Name} = undef;
356     unless ($self->{Bailed_Out}) {
357         if ( $self->{Skip_All} ) {
358             $self->parent->skip($self->{Skip_All});
359         }
360         elsif ( not @{ $self->{Test_Results} } ) {
361             $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name );
362         }
363         else {
364             $self->parent->ok( $self->is_passing, $self->name );
365         }
366     }
367     $? = $self->{Child_Error};
368     delete $self->{Parent};
369
370     return $self->is_passing;
371 }
372
373 sub _indent      {
374     my $self = shift;
375
376     if( @_ ) {
377         $self->{Indent} = shift;
378     }
379
380     return $self->{Indent};
381 }
382
383 =item B<parent>
384
385  if ( my $parent = $builder->parent ) {
386      ...
387  }
388
389 Returns the parent C<Test::Builder> instance, if any.  Only used with child
390 builders for nested TAP.
391
392 =cut
393
394 sub parent { shift->{Parent} }
395
396 =item B<name>
397
398  diag $builder->name;
399
400 Returns the name of the current builder.  Top level builders default to C<$0>
401 (the name of the executable).  Child builders are named via the C<child>
402 method.  If no name is supplied, will be named "Child of $parent->name".
403
404 =cut
405
406 sub name { shift->{Name} }
407
408 sub DESTROY {
409     my $self = shift;
410     if ( $self->parent and $$ == $self->{Original_Pid} ) {
411         my $name = $self->name;
412         $self->diag(<<"FAIL");
413 Child ($name) exited without calling finalize()
414 FAIL
415         $self->parent->{In_Destroy} = 1;
416         $self->parent->ok(0, $name);
417     }
418 }
419
420 =item B<reset>
421
422   $Test->reset;
423
424 Reinitializes the Test::Builder singleton to its original state.
425 Mostly useful for tests run in persistent environments where the same
426 test might be run multiple times in the same process.
427
428 =cut
429
430 our $Level;
431
432 sub reset {    ## no critic (Subroutines::ProhibitBuiltinHomonyms)
433     my($self) = @_;
434
435     # We leave this a global because it has to be localized and localizing
436     # hash keys is just asking for pain.  Also, it was documented.
437     $Level = 1;
438
439     $self->{Name}         = $0;
440     $self->is_passing(1);
441     $self->{Ending}       = 0;
442     $self->{Have_Plan}    = 0;
443     $self->{No_Plan}      = 0;
444     $self->{Have_Output_Plan} = 0;
445     $self->{Done_Testing} = 0;
446
447     $self->{Original_Pid} = $$;
448     $self->{Child_Name}   = undef;
449     $self->{Indent}     ||= '';
450
451     $self->{Curr_Test} = 0;
452     $self->{Test_Results} = &share( [] );
453
454     $self->{Exported_To}    = undef;
455     $self->{Expected_Tests} = 0;
456
457     $self->{Skip_All} = 0;
458
459     $self->{Use_Nums} = 1;
460
461     $self->{No_Header} = 0;
462     $self->{No_Ending} = 0;
463
464     $self->{Todo}       = undef;
465     $self->{Todo_Stack} = [];
466     $self->{Start_Todo} = 0;
467     $self->{Opened_Testhandles} = 0;
468
469     $self->_share_keys;
470     $self->_dup_stdhandles;
471
472     return;
473 }
474
475
476 # Shared scalar values are lost when a hash is copied, so we have
477 # a separate method to restore them.
478 # Shared references are retained across copies.
479 sub _share_keys {
480     my $self = shift;
481
482     share( $self->{Curr_Test} );
483
484     return;
485 }
486
487
488 =back
489
490 =head2 Setting up tests
491
492 These methods are for setting up tests and declaring how many there
493 are.  You usually only want to call one of these methods.
494
495 =over 4
496
497 =item B<plan>
498
499   $Test->plan('no_plan');
500   $Test->plan( skip_all => $reason );
501   $Test->plan( tests => $num_tests );
502
503 A convenient way to set up your tests.  Call this and Test::Builder
504 will print the appropriate headers and take the appropriate actions.
505
506 If you call C<plan()>, don't call any of the other methods below.
507
508 If a child calls "skip_all" in the plan, a C<Test::Builder::Exception> is
509 thrown.  Trap this error, call C<finalize()> and don't run any more tests on
510 the child.
511
512  my $child = $Test->child('some child');
513  eval { $child->plan( $condition ? ( skip_all => $reason ) : ( tests => 3 )  ) };
514  if ( eval { $@->isa('Test::Builder::Exception') } ) {
515     $child->finalize;
516     return;
517  }
518  # run your tests
519
520 =cut
521
522 my %plan_cmds = (
523     no_plan     => \&no_plan,
524     skip_all    => \&skip_all,
525     tests       => \&_plan_tests,
526 );
527
528 sub plan {
529     my( $self, $cmd, $arg ) = @_;
530
531     return unless $cmd;
532
533     local $Level = $Level + 1;
534
535     $self->croak("You tried to plan twice") if $self->{Have_Plan};
536
537     if( my $method = $plan_cmds{$cmd} ) {
538         local $Level = $Level + 1;
539         $self->$method($arg);
540     }
541     else {
542         my @args = grep { defined } ( $cmd, $arg );
543         $self->croak("plan() doesn't understand @args");
544     }
545
546     return 1;
547 }
548
549
550 sub _plan_tests {
551     my($self, $arg) = @_;
552
553     if($arg) {
554         local $Level = $Level + 1;
555         return $self->expected_tests($arg);
556     }
557     elsif( !defined $arg ) {
558         $self->croak("Got an undefined number of tests");
559     }
560     else {
561         $self->croak("You said to run 0 tests");
562     }
563
564     return;
565 }
566
567 =item B<expected_tests>
568
569     my $max = $Test->expected_tests;
570     $Test->expected_tests($max);
571
572 Gets/sets the number of tests we expect this test to run and prints out
573 the appropriate headers.
574
575 =cut
576
577 sub expected_tests {
578     my $self = shift;
579     my($max) = @_;
580
581     if(@_) {
582         $self->croak("Number of tests must be a positive integer.  You gave it '$max'")
583           unless $max =~ /^\+?\d+$/;
584
585         $self->{Expected_Tests} = $max;
586         $self->{Have_Plan}      = 1;
587
588         $self->_output_plan($max) unless $self->no_header;
589     }
590     return $self->{Expected_Tests};
591 }
592
593 =item B<no_plan>
594
595   $Test->no_plan;
596
597 Declares that this test will run an indeterminate number of tests.
598
599 =cut
600
601 sub no_plan {
602     my($self, $arg) = @_;
603
604     $self->carp("no_plan takes no arguments") if $arg;
605
606     $self->{No_Plan}   = 1;
607     $self->{Have_Plan} = 1;
608
609     return 1;
610 }
611
612 =begin private
613
614 =item B<_output_plan>
615
616   $tb->_output_plan($max);
617   $tb->_output_plan($max, $directive);
618   $tb->_output_plan($max, $directive => $reason);
619
620 Handles displaying the test plan.
621
622 If a C<$directive> and/or C<$reason> are given they will be output with the
623 plan.  So here's what skipping all tests looks like:
624
625     $tb->_output_plan(0, "SKIP", "Because I said so");
626
627 It sets C<< $tb->{Have_Output_Plan} >> and will croak if the plan was already
628 output.
629
630 =end private
631
632 =cut
633
634 sub _output_plan {
635     my($self, $max, $directive, $reason) = @_;
636
637     $self->carp("The plan was already output") if $self->{Have_Output_Plan};
638
639     my $plan = "1..$max";
640     $plan .= " # $directive" if defined $directive;
641     $plan .= " $reason"      if defined $reason;
642
643     $self->_print("$plan\n");
644
645     $self->{Have_Output_Plan} = 1;
646
647     return;
648 }
649
650
651 =item B<done_testing>
652
653   $Test->done_testing();
654   $Test->done_testing($num_tests);
655
656 Declares that you are done testing, no more tests will be run after this point.
657
658 If a plan has not yet been output, it will do so.
659
660 $num_tests is the number of tests you planned to run.  If a numbered
661 plan was already declared, and if this contradicts, a failing test
662 will be run to reflect the planning mistake.  If C<no_plan> was declared,
663 this will override.
664
665 If C<done_testing()> is called twice, the second call will issue a
666 failing test.
667
668 If C<$num_tests> is omitted, the number of tests run will be used, like
669 no_plan.
670
671 C<done_testing()> is, in effect, used when you'd want to use C<no_plan>, but
672 safer. You'd use it like so:
673
674     $Test->ok($a == $b);
675     $Test->done_testing();
676
677 Or to plan a variable number of tests:
678
679     for my $test (@tests) {
680         $Test->ok($test);
681     }
682     $Test->done_testing(scalar @tests);
683
684 =cut
685
686 sub done_testing {
687     my($self, $num_tests) = @_;
688
689     # If done_testing() specified the number of tests, shut off no_plan.
690     if( defined $num_tests ) {
691         $self->{No_Plan} = 0;
692     }
693     else {
694         $num_tests = $self->current_test;
695     }
696
697     if( $self->{Done_Testing} ) {
698         my($file, $line) = @{$self->{Done_Testing}}[1,2];
699         $self->ok(0, "done_testing() was already called at $file line $line");
700         return;
701     }
702
703     $self->{Done_Testing} = [caller];
704
705     if( $self->expected_tests && $num_tests != $self->expected_tests ) {
706         $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
707                      "but done_testing() expects $num_tests");
708     }
709     else {
710         $self->{Expected_Tests} = $num_tests;
711     }
712
713     $self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
714
715     $self->{Have_Plan} = 1;
716
717     # The wrong number of tests were run
718     $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test};
719
720     # No tests were run
721     $self->is_passing(0) if $self->{Curr_Test} == 0;
722
723     return 1;
724 }
725
726
727 =item B<has_plan>
728
729   $plan = $Test->has_plan
730
731 Find out whether a plan has been defined. C<$plan> is either C<undef> (no plan
732 has been set), C<no_plan> (indeterminate # of tests) or an integer (the number
733 of expected tests).
734
735 =cut
736
737 sub has_plan {
738     my $self = shift;
739
740     return( $self->{Expected_Tests} ) if $self->{Expected_Tests};
741     return('no_plan') if $self->{No_Plan};
742     return(undef);
743 }
744
745 =item B<skip_all>
746
747   $Test->skip_all;
748   $Test->skip_all($reason);
749
750 Skips all the tests, using the given C<$reason>.  Exits immediately with 0.
751
752 =cut
753
754 sub skip_all {
755     my( $self, $reason ) = @_;
756
757     $self->{Skip_All} = $self->parent ? $reason : 1;
758
759     $self->_output_plan(0, "SKIP", $reason) unless $self->no_header;
760     if ( $self->parent ) {
761         die bless {} => 'Test::Builder::Exception';
762     }
763     exit(0);
764 }
765
766 =item B<exported_to>
767
768   my $pack = $Test->exported_to;
769   $Test->exported_to($pack);
770
771 Tells Test::Builder what package you exported your functions to.
772
773 This method isn't terribly useful since modules which share the same
774 Test::Builder object might get exported to different packages and only
775 the last one will be honored.
776
777 =cut
778
779 sub exported_to {
780     my( $self, $pack ) = @_;
781
782     if( defined $pack ) {
783         $self->{Exported_To} = $pack;
784     }
785     return $self->{Exported_To};
786 }
787
788 =back
789
790 =head2 Running tests
791
792 These actually run the tests, analogous to the functions in Test::More.
793
794 They all return true if the test passed, false if the test failed.
795
796 C<$name> is always optional.
797
798 =over 4
799
800 =item B<ok>
801
802   $Test->ok($test, $name);
803
804 Your basic test.  Pass if C<$test> is true, fail if $test is false.  Just
805 like Test::Simple's C<ok()>.
806
807 =cut
808
809 sub ok {
810     my( $self, $test, $name ) = @_;
811
812     if ( $self->{Child_Name} and not $self->{In_Destroy} ) {
813         $name = 'unnamed test' unless defined $name;
814         $self->is_passing(0);
815         $self->croak("Cannot run test ($name) with active children");
816     }
817     # $test might contain an object which we don't want to accidentally
818     # store, so we turn it into a boolean.
819     $test = $test ? 1 : 0;
820
821     lock $self->{Curr_Test};
822     $self->{Curr_Test}++;
823
824     # In case $name is a string overloaded object, force it to stringify.
825     $self->_unoverload_str( \$name );
826
827     $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
828     You named your test '$name'.  You shouldn't use numbers for your test names.
829     Very confusing.
830 ERR
831
832     # Capture the value of $TODO for the rest of this ok() call
833     # so it can more easily be found by other routines.
834     my $todo    = $self->todo();
835     my $in_todo = $self->in_todo;
836     local $self->{Todo} = $todo if $in_todo;
837
838     $self->_unoverload_str( \$todo );
839
840     my $out;
841     my $result = &share( {} );
842
843     unless($test) {
844         $out .= "not ";
845         @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
846     }
847     else {
848         @$result{ 'ok', 'actual_ok' } = ( 1, $test );
849     }
850
851     $out .= "ok";
852     $out .= " $self->{Curr_Test}" if $self->use_numbers;
853
854     if( defined $name ) {
855         $name =~ s|#|\\#|g;    # # in a name can confuse Test::Harness.
856         $out .= " - $name";
857         $result->{name} = $name;
858     }
859     else {
860         $result->{name} = '';
861     }
862
863     if( $self->in_todo ) {
864         $out .= " # TODO $todo";
865         $result->{reason} = $todo;
866         $result->{type}   = 'todo';
867     }
868     else {
869         $result->{reason} = '';
870         $result->{type}   = '';
871     }
872
873     $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
874     $out .= "\n";
875
876     $self->_print($out);
877
878     unless($test) {
879         my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
880         $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
881
882         my( undef, $file, $line ) = $self->caller;
883         if( defined $name ) {
884             $self->diag(qq[  $msg test '$name'\n]);
885             $self->diag(qq[  at $file line $line.\n]);
886         }
887         else {
888             $self->diag(qq[  $msg test at $file line $line.\n]);
889         }
890     }
891
892     $self->is_passing(0) unless $test || $self->in_todo;
893
894     # Check that we haven't violated the plan
895     $self->_check_is_passing_plan();
896
897     return $test ? 1 : 0;
898 }
899
900
901 # Check that we haven't yet violated the plan and set
902 # is_passing() accordingly
903 sub _check_is_passing_plan {
904     my $self = shift;
905
906     my $plan = $self->has_plan;
907     return unless defined $plan;        # no plan yet defined
908     return unless $plan !~ /\D/;        # no numeric plan
909     $self->is_passing(0) if $plan < $self->{Curr_Test};
910 }
911
912
913 sub _unoverload {
914     my $self = shift;
915     my $type = shift;
916
917     $self->_try(sub { require overload; }, die_on_fail => 1);
918
919     foreach my $thing (@_) {
920         if( $self->_is_object($$thing) ) {
921             if( my $string_meth = overload::Method( $$thing, $type ) ) {
922                 $$thing = $$thing->$string_meth();
923             }
924         }
925     }
926
927     return;
928 }
929
930 sub _is_object {
931     my( $self, $thing ) = @_;
932
933     return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
934 }
935
936 sub _unoverload_str {
937     my $self = shift;
938
939     return $self->_unoverload( q[""], @_ );
940 }
941
942 sub _unoverload_num {
943     my $self = shift;
944
945     $self->_unoverload( '0+', @_ );
946
947     for my $val (@_) {
948         next unless $self->_is_dualvar($$val);
949         $$val = $$val + 0;
950     }
951
952     return;
953 }
954
955 # This is a hack to detect a dualvar such as $!
956 sub _is_dualvar {
957     my( $self, $val ) = @_;
958
959     # Objects are not dualvars.
960     return 0 if ref $val;
961
962     no warnings 'numeric';
963     my $numval = $val + 0;
964     return ($numval != 0 and $numval ne $val ? 1 : 0);
965 }
966
967 =item B<is_eq>
968
969   $Test->is_eq($got, $expected, $name);
970
971 Like Test::More's C<is()>.  Checks if C<$got eq $expected>.  This is the
972 string version.
973
974 C<undef> only ever matches another C<undef>.
975
976 =item B<is_num>
977
978   $Test->is_num($got, $expected, $name);
979
980 Like Test::More's C<is()>.  Checks if C<$got == $expected>.  This is the
981 numeric version.
982
983 C<undef> only ever matches another C<undef>.
984
985 =cut
986
987 sub is_eq {
988     my( $self, $got, $expect, $name ) = @_;
989     local $Level = $Level + 1;
990
991     if( !defined $got || !defined $expect ) {
992         # undef only matches undef and nothing else
993         my $test = !defined $got && !defined $expect;
994
995         $self->ok( $test, $name );
996         $self->_is_diag( $got, 'eq', $expect ) unless $test;
997         return $test;
998     }
999
1000     return $self->cmp_ok( $got, 'eq', $expect, $name );
1001 }
1002
1003 sub is_num {
1004     my( $self, $got, $expect, $name ) = @_;
1005     local $Level = $Level + 1;
1006
1007     if( !defined $got || !defined $expect ) {
1008         # undef only matches undef and nothing else
1009         my $test = !defined $got && !defined $expect;
1010
1011         $self->ok( $test, $name );
1012         $self->_is_diag( $got, '==', $expect ) unless $test;
1013         return $test;
1014     }
1015
1016     return $self->cmp_ok( $got, '==', $expect, $name );
1017 }
1018
1019 sub _diag_fmt {
1020     my( $self, $type, $val ) = @_;
1021
1022     if( defined $$val ) {
1023         if( $type eq 'eq' or $type eq 'ne' ) {
1024             # quote and force string context
1025             $$val = "'$$val'";
1026         }
1027         else {
1028             # force numeric context
1029             $self->_unoverload_num($val);
1030         }
1031     }
1032     else {
1033         $$val = 'undef';
1034     }
1035
1036     return;
1037 }
1038
1039 sub _is_diag {
1040     my( $self, $got, $type, $expect ) = @_;
1041
1042     $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
1043
1044     local $Level = $Level + 1;
1045     return $self->diag(<<"DIAGNOSTIC");
1046          got: $got
1047     expected: $expect
1048 DIAGNOSTIC
1049
1050 }
1051
1052 sub _isnt_diag {
1053     my( $self, $got, $type ) = @_;
1054
1055     $self->_diag_fmt( $type, \$got );
1056
1057     local $Level = $Level + 1;
1058     return $self->diag(<<"DIAGNOSTIC");
1059          got: $got
1060     expected: anything else
1061 DIAGNOSTIC
1062 }
1063
1064 =item B<isnt_eq>
1065
1066   $Test->isnt_eq($got, $dont_expect, $name);
1067
1068 Like L<Test::More>'s C<isnt()>.  Checks if C<$got ne $dont_expect>.  This is
1069 the string version.
1070
1071 =item B<isnt_num>
1072
1073   $Test->isnt_num($got, $dont_expect, $name);
1074
1075 Like L<Test::More>'s C<isnt()>.  Checks if C<$got ne $dont_expect>.  This is
1076 the numeric version.
1077
1078 =cut
1079
1080 sub isnt_eq {
1081     my( $self, $got, $dont_expect, $name ) = @_;
1082     local $Level = $Level + 1;
1083
1084     if( !defined $got || !defined $dont_expect ) {
1085         # undef only matches undef and nothing else
1086         my $test = defined $got || defined $dont_expect;
1087
1088         $self->ok( $test, $name );
1089         $self->_isnt_diag( $got, 'ne' ) unless $test;
1090         return $test;
1091     }
1092
1093     return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
1094 }
1095
1096 sub isnt_num {
1097     my( $self, $got, $dont_expect, $name ) = @_;
1098     local $Level = $Level + 1;
1099
1100     if( !defined $got || !defined $dont_expect ) {
1101         # undef only matches undef and nothing else
1102         my $test = defined $got || defined $dont_expect;
1103
1104         $self->ok( $test, $name );
1105         $self->_isnt_diag( $got, '!=' ) unless $test;
1106         return $test;
1107     }
1108
1109     return $self->cmp_ok( $got, '!=', $dont_expect, $name );
1110 }
1111
1112 =item B<like>
1113
1114   $Test->like($thing, qr/$regex/, $name);
1115   $Test->like($thing, '/$regex/', $name);
1116
1117 Like L<Test::More>'s C<like()>.  Checks if $thing matches the given C<$regex>.
1118
1119 =item B<unlike>
1120
1121   $Test->unlike($thing, qr/$regex/, $name);
1122   $Test->unlike($thing, '/$regex/', $name);
1123
1124 Like L<Test::More>'s C<unlike()>.  Checks if $thing B<does not match> the
1125 given C<$regex>.
1126
1127 =cut
1128
1129 sub like {
1130     my( $self, $thing, $regex, $name ) = @_;
1131
1132     local $Level = $Level + 1;
1133     return $self->_regex_ok( $thing, $regex, '=~', $name );
1134 }
1135
1136 sub unlike {
1137     my( $self, $thing, $regex, $name ) = @_;
1138
1139     local $Level = $Level + 1;
1140     return $self->_regex_ok( $thing, $regex, '!~', $name );
1141 }
1142
1143 =item B<cmp_ok>
1144
1145   $Test->cmp_ok($thing, $type, $that, $name);
1146
1147 Works just like L<Test::More>'s C<cmp_ok()>.
1148
1149     $Test->cmp_ok($big_num, '!=', $other_big_num);
1150
1151 =cut
1152
1153 my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
1154
1155 # Bad, these are not comparison operators. Should we include more?
1156 my %cmp_ok_bl = map { ( $_, 1 ) } ( "=", "+=", ".=", "x=", "^=", "|=", "||=", "&&=", "...");
1157
1158 sub cmp_ok {
1159     my( $self, $got, $type, $expect, $name ) = @_;
1160
1161     if ($cmp_ok_bl{$type}) {
1162         $self->croak("$type is not a valid comparison operator in cmp_ok()");
1163     }
1164
1165     my $test;
1166     my $error;
1167     {
1168         ## no critic (BuiltinFunctions::ProhibitStringyEval)
1169
1170         local( $@, $!, $SIG{__DIE__} );    # isolate eval
1171
1172         my($pack, $file, $line) = $self->caller();
1173
1174         # This is so that warnings come out at the caller's level
1175         $test = eval qq[
1176 #line $line "(eval in cmp_ok) $file"
1177 \$got $type \$expect;
1178 ];
1179         $error = $@;
1180     }
1181     local $Level = $Level + 1;
1182     my $ok = $self->ok( $test, $name );
1183
1184     # Treat overloaded objects as numbers if we're asked to do a
1185     # numeric comparison.
1186     my $unoverload
1187       = $numeric_cmps{$type}
1188       ? '_unoverload_num'
1189       : '_unoverload_str';
1190
1191     $self->diag(<<"END") if $error;
1192 An error occurred while using $type:
1193 ------------------------------------
1194 $error
1195 ------------------------------------
1196 END
1197
1198     unless($ok) {
1199         $self->$unoverload( \$got, \$expect );
1200
1201         if( $type =~ /^(eq|==)$/ ) {
1202             $self->_is_diag( $got, $type, $expect );
1203         }
1204         elsif( $type =~ /^(ne|!=)$/ ) {
1205             $self->_isnt_diag( $got, $type );
1206         }
1207         else {
1208             $self->_cmp_diag( $got, $type, $expect );
1209         }
1210     }
1211     return $ok;
1212 }
1213
1214 sub _cmp_diag {
1215     my( $self, $got, $type, $expect ) = @_;
1216
1217     $got    = defined $got    ? "'$got'"    : 'undef';
1218     $expect = defined $expect ? "'$expect'" : 'undef';
1219
1220     local $Level = $Level + 1;
1221     return $self->diag(<<"DIAGNOSTIC");
1222     $got
1223         $type
1224     $expect
1225 DIAGNOSTIC
1226 }
1227
1228 sub _caller_context {
1229     my $self = shift;
1230
1231     my( $pack, $file, $line ) = $self->caller(1);
1232
1233     my $code = '';
1234     $code .= "#line $line $file\n" if defined $file and defined $line;
1235
1236     return $code;
1237 }
1238
1239 =back
1240
1241
1242 =head2 Other Testing Methods
1243
1244 These are methods which are used in the course of writing a test but are not themselves tests.
1245
1246 =over 4
1247
1248 =item B<BAIL_OUT>
1249
1250     $Test->BAIL_OUT($reason);
1251
1252 Indicates to the L<Test::Harness> that things are going so badly all
1253 testing should terminate.  This includes running any additional test
1254 scripts.
1255
1256 It will exit with 255.
1257
1258 =cut
1259
1260 sub BAIL_OUT {
1261     my( $self, $reason ) = @_;
1262
1263     $self->{Bailed_Out} = 1;
1264
1265     if ($self->parent) {
1266         $self->{Bailed_Out_Reason} = $reason;
1267         $self->no_ending(1);
1268         die bless {} => 'Test::Builder::Exception';
1269     }
1270
1271     $self->_print("Bail out!  $reason");
1272     exit 255;
1273 }
1274
1275 =for deprecated
1276 BAIL_OUT() used to be BAILOUT()
1277
1278 =cut
1279
1280 {
1281     no warnings 'once';
1282     *BAILOUT = \&BAIL_OUT;
1283 }
1284
1285 =item B<skip>
1286
1287     $Test->skip;
1288     $Test->skip($why);
1289
1290 Skips the current test, reporting C<$why>.
1291
1292 =cut
1293
1294 sub skip {
1295     my( $self, $why ) = @_;
1296     $why ||= '';
1297     $self->_unoverload_str( \$why );
1298
1299     lock( $self->{Curr_Test} );
1300     $self->{Curr_Test}++;
1301
1302     $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
1303         {
1304             'ok'      => 1,
1305             actual_ok => 1,
1306             name      => '',
1307             type      => 'skip',
1308             reason    => $why,
1309         }
1310     );
1311
1312     my $out = "ok";
1313     $out .= " $self->{Curr_Test}" if $self->use_numbers;
1314     $out .= " # skip";
1315     $out .= " $why"               if length $why;
1316     $out .= "\n";
1317
1318     $self->_print($out);
1319
1320     return 1;
1321 }
1322
1323 =item B<todo_skip>
1324
1325   $Test->todo_skip;
1326   $Test->todo_skip($why);
1327
1328 Like C<skip()>, only it will declare the test as failing and TODO.  Similar
1329 to
1330
1331     print "not ok $tnum # TODO $why\n";
1332
1333 =cut
1334
1335 sub todo_skip {
1336     my( $self, $why ) = @_;
1337     $why ||= '';
1338
1339     lock( $self->{Curr_Test} );
1340     $self->{Curr_Test}++;
1341
1342     $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
1343         {
1344             'ok'      => 1,
1345             actual_ok => 0,
1346             name      => '',
1347             type      => 'todo_skip',
1348             reason    => $why,
1349         }
1350     );
1351
1352     my $out = "not ok";
1353     $out .= " $self->{Curr_Test}" if $self->use_numbers;
1354     $out .= " # TODO & SKIP $why\n";
1355
1356     $self->_print($out);
1357
1358     return 1;
1359 }
1360
1361 =begin _unimplemented
1362
1363 =item B<skip_rest>
1364
1365   $Test->skip_rest;
1366   $Test->skip_rest($reason);
1367
1368 Like C<skip()>, only it skips all the rest of the tests you plan to run
1369 and terminates the test.
1370
1371 If you're running under C<no_plan>, it skips once and terminates the
1372 test.
1373
1374 =end _unimplemented
1375
1376 =back
1377
1378
1379 =head2 Test building utility methods
1380
1381 These methods are useful when writing your own test methods.
1382
1383 =over 4
1384
1385 =item B<maybe_regex>
1386
1387   $Test->maybe_regex(qr/$regex/);
1388   $Test->maybe_regex('/$regex/');
1389
1390 This method used to be useful back when Test::Builder worked on Perls
1391 before 5.6 which didn't have qr//.  Now its pretty useless.
1392
1393 Convenience method for building testing functions that take regular
1394 expressions as arguments.
1395
1396 Takes a quoted regular expression produced by C<qr//>, or a string
1397 representing a regular expression.
1398
1399 Returns a Perl value which may be used instead of the corresponding
1400 regular expression, or C<undef> if its argument is not recognised.
1401
1402 For example, a version of C<like()>, sans the useful diagnostic messages,
1403 could be written as:
1404
1405   sub laconic_like {
1406       my ($self, $thing, $regex, $name) = @_;
1407       my $usable_regex = $self->maybe_regex($regex);
1408       die "expecting regex, found '$regex'\n"
1409           unless $usable_regex;
1410       $self->ok($thing =~ m/$usable_regex/, $name);
1411   }
1412
1413 =cut
1414
1415 sub maybe_regex {
1416     my( $self, $regex ) = @_;
1417     my $usable_regex = undef;
1418
1419     return $usable_regex unless defined $regex;
1420
1421     my( $re, $opts );
1422
1423     # Check for qr/foo/
1424     if( _is_qr($regex) ) {
1425         $usable_regex = $regex;
1426     }
1427     # Check for '/foo/' or 'm,foo,'
1428     elsif(( $re, $opts )        = $regex =~ m{^ /(.*)/ (\w*) $ }sx              or
1429           ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
1430     )
1431     {
1432         $usable_regex = length $opts ? "(?$opts)$re" : $re;
1433     }
1434
1435     return $usable_regex;
1436 }
1437
1438 sub _is_qr {
1439     my $regex = shift;
1440
1441     # is_regexp() checks for regexes in a robust manner, say if they're
1442     # blessed.
1443     return re::is_regexp($regex) if defined &re::is_regexp;
1444     return ref $regex eq 'Regexp';
1445 }
1446
1447 sub _regex_ok {
1448     my( $self, $thing, $regex, $cmp, $name ) = @_;
1449
1450     my $ok           = 0;
1451     my $usable_regex = $self->maybe_regex($regex);
1452     unless( defined $usable_regex ) {
1453         local $Level = $Level + 1;
1454         $ok = $self->ok( 0, $name );
1455         $self->diag("    '$regex' doesn't look much like a regex to me.");
1456         return $ok;
1457     }
1458
1459     {
1460         my $test;
1461         my $context = $self->_caller_context;
1462
1463         {
1464             ## no critic (BuiltinFunctions::ProhibitStringyEval)
1465
1466             local( $@, $!, $SIG{__DIE__} );    # isolate eval
1467
1468             # No point in issuing an uninit warning, they'll see it in the diagnostics
1469             no warnings 'uninitialized';
1470
1471             $test = eval $context . q{$test = $thing =~ /$usable_regex/ ? 1 : 0};
1472         }
1473
1474         $test = !$test if $cmp eq '!~';
1475
1476         local $Level = $Level + 1;
1477         $ok = $self->ok( $test, $name );
1478     }
1479
1480     unless($ok) {
1481         $thing = defined $thing ? "'$thing'" : 'undef';
1482         my $match = $cmp eq '=~' ? "doesn't match" : "matches";
1483
1484         local $Level = $Level + 1;
1485         $self->diag( sprintf <<'DIAGNOSTIC', $thing, $match, $regex );
1486                   %s
1487     %13s '%s'
1488 DIAGNOSTIC
1489
1490     }
1491
1492     return $ok;
1493 }
1494
1495 # I'm not ready to publish this.  It doesn't deal with array return
1496 # values from the code or context.
1497
1498 =begin private
1499
1500 =item B<_try>
1501
1502     my $return_from_code          = $Test->try(sub { code });
1503     my($return_from_code, $error) = $Test->try(sub { code });
1504
1505 Works like eval BLOCK except it ensures it has no effect on the rest
1506 of the test (ie. C<$@> is not set) nor is effected by outside
1507 interference (ie. C<$SIG{__DIE__}>) and works around some quirks in older
1508 Perls.
1509
1510 C<$error> is what would normally be in C<$@>.
1511
1512 It is suggested you use this in place of eval BLOCK.
1513
1514 =cut
1515
1516 sub _try {
1517     my( $self, $code, %opts ) = @_;
1518
1519     my $error;
1520     my $return;
1521     {
1522         local $!;               # eval can mess up $!
1523         local $@;               # don't set $@ in the test
1524         local $SIG{__DIE__};    # don't trip an outside DIE handler.
1525         $return = eval { $code->() };
1526         $error = $@;
1527     }
1528
1529     die $error if $error and $opts{die_on_fail};
1530
1531     return wantarray ? ( $return, $error ) : $return;
1532 }
1533
1534 =end private
1535
1536
1537 =item B<is_fh>
1538
1539     my $is_fh = $Test->is_fh($thing);
1540
1541 Determines if the given C<$thing> can be used as a filehandle.
1542
1543 =cut
1544
1545 sub is_fh {
1546     my $self     = shift;
1547     my $maybe_fh = shift;
1548     return 0 unless defined $maybe_fh;
1549
1550     return 1 if ref $maybe_fh  eq 'GLOB';    # its a glob ref
1551     return 1 if ref \$maybe_fh eq 'GLOB';    # its a glob
1552
1553     return eval { $maybe_fh->isa("IO::Handle") } ||
1554            eval { tied($maybe_fh)->can('TIEHANDLE') };
1555 }
1556
1557 =back
1558
1559
1560 =head2 Test style
1561
1562
1563 =over 4
1564
1565 =item B<level>
1566
1567     $Test->level($how_high);
1568
1569 How far up the call stack should C<$Test> look when reporting where the
1570 test failed.
1571
1572 Defaults to 1.
1573
1574 Setting L<$Test::Builder::Level> overrides.  This is typically useful
1575 localized:
1576
1577     sub my_ok {
1578         my $test = shift;
1579
1580         local $Test::Builder::Level = $Test::Builder::Level + 1;
1581         $TB->ok($test);
1582     }
1583
1584 To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant.
1585
1586 =cut
1587
1588 sub level {
1589     my( $self, $level ) = @_;
1590
1591     if( defined $level ) {
1592         $Level = $level;
1593     }
1594     return $Level;
1595 }
1596
1597 =item B<use_numbers>
1598
1599     $Test->use_numbers($on_or_off);
1600
1601 Whether or not the test should output numbers.  That is, this if true:
1602
1603   ok 1
1604   ok 2
1605   ok 3
1606
1607 or this if false
1608
1609   ok
1610   ok
1611   ok
1612
1613 Most useful when you can't depend on the test output order, such as
1614 when threads or forking is involved.
1615
1616 Defaults to on.
1617
1618 =cut
1619
1620 sub use_numbers {
1621     my( $self, $use_nums ) = @_;
1622
1623     if( defined $use_nums ) {
1624         $self->{Use_Nums} = $use_nums;
1625     }
1626     return $self->{Use_Nums};
1627 }
1628
1629 =item B<no_diag>
1630
1631     $Test->no_diag($no_diag);
1632
1633 If set true no diagnostics will be printed.  This includes calls to
1634 C<diag()>.
1635
1636 =item B<no_ending>
1637
1638     $Test->no_ending($no_ending);
1639
1640 Normally, Test::Builder does some extra diagnostics when the test
1641 ends.  It also changes the exit code as described below.
1642
1643 If this is true, none of that will be done.
1644
1645 =item B<no_header>
1646
1647     $Test->no_header($no_header);
1648
1649 If set to true, no "1..N" header will be printed.
1650
1651 =cut
1652
1653 foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
1654     my $method = lc $attribute;
1655
1656     my $code = sub {
1657         my( $self, $no ) = @_;
1658
1659         if( defined $no ) {
1660             $self->{$attribute} = $no;
1661         }
1662         return $self->{$attribute};
1663     };
1664
1665     no strict 'refs';    ## no critic
1666     *{ __PACKAGE__ . '::' . $method } = $code;
1667 }
1668
1669 =back
1670
1671 =head2 Output
1672
1673 Controlling where the test output goes.
1674
1675 It's ok for your test to change where STDOUT and STDERR point to,
1676 Test::Builder's default output settings will not be affected.
1677
1678 =over 4
1679
1680 =item B<diag>
1681
1682     $Test->diag(@msgs);
1683
1684 Prints out the given C<@msgs>.  Like C<print>, arguments are simply
1685 appended together.
1686
1687 Normally, it uses the C<failure_output()> handle, but if this is for a
1688 TODO test, the C<todo_output()> handle is used.
1689
1690 Output will be indented and marked with a # so as not to interfere
1691 with test output.  A newline will be put on the end if there isn't one
1692 already.
1693
1694 We encourage using this rather than calling print directly.
1695
1696 Returns false.  Why?  Because C<diag()> is often used in conjunction with
1697 a failing test (C<ok() || diag()>) it "passes through" the failure.
1698
1699     return ok(...) || diag(...);
1700
1701 =for blame transfer
1702 Mark Fowler <mark@twoshortplanks.com>
1703
1704 =cut
1705
1706 sub diag {
1707     my $self = shift;
1708
1709     $self->_print_comment( $self->_diag_fh, @_ );
1710 }
1711
1712 =item B<note>
1713
1714     $Test->note(@msgs);
1715
1716 Like C<diag()>, but it prints to the C<output()> handle so it will not
1717 normally be seen by the user except in verbose mode.
1718
1719 =cut
1720
1721 sub note {
1722     my $self = shift;
1723
1724     $self->_print_comment( $self->output, @_ );
1725 }
1726
1727 sub _diag_fh {
1728     my $self = shift;
1729
1730     local $Level = $Level + 1;
1731     return $self->in_todo ? $self->todo_output : $self->failure_output;
1732 }
1733
1734 sub _print_comment {
1735     my( $self, $fh, @msgs ) = @_;
1736
1737     return if $self->no_diag;
1738     return unless @msgs;
1739
1740     # Prevent printing headers when compiling (i.e. -c)
1741     return if $^C;
1742
1743     # Smash args together like print does.
1744     # Convert undef to 'undef' so its readable.
1745     my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1746
1747     # Escape the beginning, _print will take care of the rest.
1748     $msg =~ s/^/# /;
1749
1750     local $Level = $Level + 1;
1751     $self->_print_to_fh( $fh, $msg );
1752
1753     return 0;
1754 }
1755
1756 =item B<explain>
1757
1758     my @dump = $Test->explain(@msgs);
1759
1760 Will dump the contents of any references in a human readable format.
1761 Handy for things like...
1762
1763     is_deeply($have, $want) || diag explain $have;
1764
1765 or
1766
1767     is_deeply($have, $want) || note explain $have;
1768
1769 =cut
1770
1771 sub explain {
1772     my $self = shift;
1773
1774     return map {
1775         ref $_
1776           ? do {
1777             $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
1778
1779             my $dumper = Data::Dumper->new( [$_] );
1780             $dumper->Indent(1)->Terse(1);
1781             $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
1782             $dumper->Dump;
1783           }
1784           : $_
1785     } @_;
1786 }
1787
1788 =begin _private
1789
1790 =item B<_print>
1791
1792     $Test->_print(@msgs);
1793
1794 Prints to the C<output()> filehandle.
1795
1796 =end _private
1797
1798 =cut
1799
1800 sub _print {
1801     my $self = shift;
1802     return $self->_print_to_fh( $self->output, @_ );
1803 }
1804
1805 sub _print_to_fh {
1806     my( $self, $fh, @msgs ) = @_;
1807
1808     # Prevent printing headers when only compiling.  Mostly for when
1809     # tests are deparsed with B::Deparse
1810     return if $^C;
1811
1812     my $msg = join '', @msgs;
1813     my $indent = $self->_indent;
1814
1815     local( $\, $", $, ) = ( undef, ' ', '' );
1816
1817     # Escape each line after the first with a # so we don't
1818     # confuse Test::Harness.
1819     $msg =~ s{\n(?!\z)}{\n$indent# }sg;
1820
1821     # Stick a newline on the end if it needs it.
1822     $msg .= "\n" unless $msg =~ /\n\z/;
1823
1824     return print $fh $indent, $msg;
1825 }
1826
1827 =item B<output>
1828
1829 =item B<failure_output>
1830
1831 =item B<todo_output>
1832
1833     my $filehandle = $Test->output;
1834     $Test->output($filehandle);
1835     $Test->output($filename);
1836     $Test->output(\$scalar);
1837
1838 These methods control where Test::Builder will print its output.
1839 They take either an open C<$filehandle>, a C<$filename> to open and write to
1840 or a C<$scalar> reference to append to.  It will always return a C<$filehandle>.
1841
1842 B<output> is where normal "ok/not ok" test output goes.
1843
1844 Defaults to STDOUT.
1845
1846 B<failure_output> is where diagnostic output on test failures and
1847 C<diag()> goes.  It is normally not read by Test::Harness and instead is
1848 displayed to the user.
1849
1850 Defaults to STDERR.
1851
1852 C<todo_output> is used instead of C<failure_output()> for the
1853 diagnostics of a failing TODO test.  These will not be seen by the
1854 user.
1855
1856 Defaults to STDOUT.
1857
1858 =cut
1859
1860 sub output {
1861     my( $self, $fh ) = @_;
1862
1863     if( defined $fh ) {
1864         $self->{Out_FH} = $self->_new_fh($fh);
1865     }
1866     return $self->{Out_FH};
1867 }
1868
1869 sub failure_output {
1870     my( $self, $fh ) = @_;
1871
1872     if( defined $fh ) {
1873         $self->{Fail_FH} = $self->_new_fh($fh);
1874     }
1875     return $self->{Fail_FH};
1876 }
1877
1878 sub todo_output {
1879     my( $self, $fh ) = @_;
1880
1881     if( defined $fh ) {
1882         $self->{Todo_FH} = $self->_new_fh($fh);
1883     }
1884     return $self->{Todo_FH};
1885 }
1886
1887 sub _new_fh {
1888     my $self = shift;
1889     my($file_or_fh) = shift;
1890
1891     my $fh;
1892     if( $self->is_fh($file_or_fh) ) {
1893         $fh = $file_or_fh;
1894     }
1895     elsif( ref $file_or_fh eq 'SCALAR' ) {
1896         # Scalar refs as filehandles was added in 5.8.
1897         if( $] >= 5.008 ) {
1898             open $fh, ">>", $file_or_fh
1899               or $self->croak("Can't open scalar ref $file_or_fh: $!");
1900         }
1901         # Emulate scalar ref filehandles with a tie.
1902         else {
1903             $fh = Test::Builder::IO::Scalar->new($file_or_fh)
1904               or $self->croak("Can't tie scalar ref $file_or_fh");
1905         }
1906     }
1907     else {
1908         open $fh, ">", $file_or_fh
1909           or $self->croak("Can't open test output log $file_or_fh: $!");
1910         _autoflush($fh);
1911     }
1912
1913     return $fh;
1914 }
1915
1916 sub _autoflush {
1917     my($fh) = shift;
1918     my $old_fh = select $fh;
1919     $| = 1;
1920     select $old_fh;
1921
1922     return;
1923 }
1924
1925 my( $Testout, $Testerr );
1926
1927 sub _dup_stdhandles {
1928     my $self = shift;
1929
1930     $self->_open_testhandles;
1931
1932     # Set everything to unbuffered else plain prints to STDOUT will
1933     # come out in the wrong order from our own prints.
1934     _autoflush($Testout);
1935     _autoflush( \*STDOUT );
1936     _autoflush($Testerr);
1937     _autoflush( \*STDERR );
1938
1939     $self->reset_outputs;
1940
1941     return;
1942 }
1943
1944 sub _open_testhandles {
1945     my $self = shift;
1946
1947     return if $self->{Opened_Testhandles};
1948
1949     # We dup STDOUT and STDERR so people can change them in their
1950     # test suites while still getting normal test output.
1951     open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT:  $!";
1952     open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR:  $!";
1953
1954     $self->_copy_io_layers( \*STDOUT, $Testout );
1955     $self->_copy_io_layers( \*STDERR, $Testerr );
1956
1957     $self->{Opened_Testhandles} = 1;
1958
1959     return;
1960 }
1961
1962 sub _copy_io_layers {
1963     my( $self, $src, $dst ) = @_;
1964
1965     $self->_try(
1966         sub {
1967             require PerlIO;
1968             my @src_layers = PerlIO::get_layers($src);
1969
1970             _apply_layers($dst, @src_layers) if @src_layers;
1971         }
1972     );
1973
1974     return;
1975 }
1976
1977 sub _apply_layers {
1978     my ($fh, @layers) = @_;
1979     my %seen;
1980     my @unique = grep { $_ ne 'unix' and !$seen{$_}++ } @layers;
1981     binmode($fh, join(":", "", "raw", @unique));
1982 }
1983
1984
1985 =item reset_outputs
1986
1987   $tb->reset_outputs;
1988
1989 Resets all the output filehandles back to their defaults.
1990
1991 =cut
1992
1993 sub reset_outputs {
1994     my $self = shift;
1995
1996     $self->output        ($Testout);
1997     $self->failure_output($Testerr);
1998     $self->todo_output   ($Testout);
1999
2000     return;
2001 }
2002
2003 =item carp
2004
2005   $tb->carp(@message);
2006
2007 Warns with C<@message> but the message will appear to come from the
2008 point where the original test function was called (C<< $tb->caller >>).
2009
2010 =item croak
2011
2012   $tb->croak(@message);
2013
2014 Dies with C<@message> but the message will appear to come from the
2015 point where the original test function was called (C<< $tb->caller >>).
2016
2017 =cut
2018
2019 sub _message_at_caller {
2020     my $self = shift;
2021
2022     local $Level = $Level + 1;
2023     my( $pack, $file, $line ) = $self->caller;
2024     return join( "", @_ ) . " at $file line $line.\n";
2025 }
2026
2027 sub carp {
2028     my $self = shift;
2029     return warn $self->_message_at_caller(@_);
2030 }
2031
2032 sub croak {
2033     my $self = shift;
2034     return die $self->_message_at_caller(@_);
2035 }
2036
2037
2038 =back
2039
2040
2041 =head2 Test Status and Info
2042
2043 =over 4
2044
2045 =item B<current_test>
2046
2047     my $curr_test = $Test->current_test;
2048     $Test->current_test($num);
2049
2050 Gets/sets the current test number we're on.  You usually shouldn't
2051 have to set this.
2052
2053 If set forward, the details of the missing tests are filled in as 'unknown'.
2054 if set backward, the details of the intervening tests are deleted.  You
2055 can erase history if you really want to.
2056
2057 =cut
2058
2059 sub current_test {
2060     my( $self, $num ) = @_;
2061
2062     lock( $self->{Curr_Test} );
2063     if( defined $num ) {
2064         $self->{Curr_Test} = $num;
2065
2066         # If the test counter is being pushed forward fill in the details.
2067         my $test_results = $self->{Test_Results};
2068         if( $num > @$test_results ) {
2069             my $start = @$test_results ? @$test_results : 0;
2070             for( $start .. $num - 1 ) {
2071                 $test_results->[$_] = &share(
2072                     {
2073                         'ok'      => 1,
2074                         actual_ok => undef,
2075                         reason    => 'incrementing test number',
2076                         type      => 'unknown',
2077                         name      => undef
2078                     }
2079                 );
2080             }
2081         }
2082         # If backward, wipe history.  Its their funeral.
2083         elsif( $num < @$test_results ) {
2084             $#{$test_results} = $num - 1;
2085         }
2086     }
2087     return $self->{Curr_Test};
2088 }
2089
2090 =item B<is_passing>
2091
2092    my $ok = $builder->is_passing;
2093
2094 Indicates if the test suite is currently passing.
2095
2096 More formally, it will be false if anything has happened which makes
2097 it impossible for the test suite to pass.  True otherwise.
2098
2099 For example, if no tests have run C<is_passing()> will be true because
2100 even though a suite with no tests is a failure you can add a passing
2101 test to it and start passing.
2102
2103 Don't think about it too much.
2104
2105 =cut
2106
2107 sub is_passing {
2108     my $self = shift;
2109
2110     if( @_ ) {
2111         $self->{Is_Passing} = shift;
2112     }
2113
2114     return $self->{Is_Passing};
2115 }
2116
2117
2118 =item B<summary>
2119
2120     my @tests = $Test->summary;
2121
2122 A simple summary of the tests so far.  True for pass, false for fail.
2123 This is a logical pass/fail, so todos are passes.
2124
2125 Of course, test #1 is $tests[0], etc...
2126
2127 =cut
2128
2129 sub summary {
2130     my($self) = shift;
2131
2132     return map { $_->{'ok'} } @{ $self->{Test_Results} };
2133 }
2134
2135 =item B<details>
2136
2137     my @tests = $Test->details;
2138
2139 Like C<summary()>, but with a lot more detail.
2140
2141     $tests[$test_num - 1] = 
2142             { 'ok'       => is the test considered a pass?
2143               actual_ok  => did it literally say 'ok'?
2144               name       => name of the test (if any)
2145               type       => type of test (if any, see below).
2146               reason     => reason for the above (if any)
2147             };
2148
2149 'ok' is true if Test::Harness will consider the test to be a pass.
2150
2151 'actual_ok' is a reflection of whether or not the test literally
2152 printed 'ok' or 'not ok'.  This is for examining the result of 'todo'
2153 tests.
2154
2155 'name' is the name of the test.
2156
2157 'type' indicates if it was a special test.  Normal tests have a type
2158 of ''.  Type can be one of the following:
2159
2160     skip        see skip()
2161     todo        see todo()
2162     todo_skip   see todo_skip()
2163     unknown     see below
2164
2165 Sometimes the Test::Builder test counter is incremented without it
2166 printing any test output, for example, when C<current_test()> is changed.
2167 In these cases, Test::Builder doesn't know the result of the test, so
2168 its type is 'unknown'.  These details for these tests are filled in.
2169 They are considered ok, but the name and actual_ok is left C<undef>.
2170
2171 For example "not ok 23 - hole count # TODO insufficient donuts" would
2172 result in this structure:
2173
2174     $tests[22] =    # 23 - 1, since arrays start from 0.
2175       { ok        => 1,   # logically, the test passed since its todo
2176         actual_ok => 0,   # in absolute terms, it failed
2177         name      => 'hole count',
2178         type      => 'todo',
2179         reason    => 'insufficient donuts'
2180       };
2181
2182 =cut
2183
2184 sub details {
2185     my $self = shift;
2186     return @{ $self->{Test_Results} };
2187 }
2188
2189 =item B<todo>
2190
2191     my $todo_reason = $Test->todo;
2192     my $todo_reason = $Test->todo($pack);
2193
2194 If the current tests are considered "TODO" it will return the reason,
2195 if any.  This reason can come from a C<$TODO> variable or the last call
2196 to C<todo_start()>.
2197
2198 Since a TODO test does not need a reason, this function can return an
2199 empty string even when inside a TODO block.  Use C<< $Test->in_todo >>
2200 to determine if you are currently inside a TODO block.
2201
2202 C<todo()> is about finding the right package to look for C<$TODO> in.  It's
2203 pretty good at guessing the right package to look at.  It first looks for
2204 the caller based on C<$Level + 1>, since C<todo()> is usually called inside
2205 a test function.  As a last resort it will use C<exported_to()>.
2206
2207 Sometimes there is some confusion about where C<todo()> should be looking
2208 for the C<$TODO> variable.  If you want to be sure, tell it explicitly
2209 what $pack to use.
2210
2211 =cut
2212
2213 sub todo {
2214     my( $self, $pack ) = @_;
2215
2216     return $self->{Todo} if defined $self->{Todo};
2217
2218     local $Level = $Level + 1;
2219     my $todo = $self->find_TODO($pack);
2220     return $todo if defined $todo;
2221
2222     return '';
2223 }
2224
2225 =item B<find_TODO>
2226
2227     my $todo_reason = $Test->find_TODO();
2228     my $todo_reason = $Test->find_TODO($pack);
2229
2230 Like C<todo()> but only returns the value of C<$TODO> ignoring
2231 C<todo_start()>.
2232
2233 Can also be used to set C<$TODO> to a new value while returning the
2234 old value:
2235
2236     my $old_reason = $Test->find_TODO($pack, 1, $new_reason);
2237
2238 =cut
2239
2240 sub find_TODO {
2241     my( $self, $pack, $set, $new_value ) = @_;
2242
2243     $pack = $pack || $self->caller(1) || $self->exported_to;
2244     return unless $pack;
2245
2246     no strict 'refs';    ## no critic
2247     my $old_value = ${ $pack . '::TODO' };
2248     $set and ${ $pack . '::TODO' } = $new_value;
2249     return $old_value;
2250 }
2251
2252 =item B<in_todo>
2253
2254     my $in_todo = $Test->in_todo;
2255
2256 Returns true if the test is currently inside a TODO block.
2257
2258 =cut
2259
2260 sub in_todo {
2261     my $self = shift;
2262
2263     local $Level = $Level + 1;
2264     return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
2265 }
2266
2267 =item B<todo_start>
2268
2269     $Test->todo_start();
2270     $Test->todo_start($message);
2271
2272 This method allows you declare all subsequent tests as TODO tests, up until
2273 the C<todo_end> method has been called.
2274
2275 The C<TODO:> and C<$TODO> syntax is generally pretty good about figuring out
2276 whether or not we're in a TODO test.  However, often we find that this is not
2277 possible to determine (such as when we want to use C<$TODO> but
2278 the tests are being executed in other packages which can't be inferred
2279 beforehand).
2280
2281 Note that you can use this to nest "todo" tests
2282
2283  $Test->todo_start('working on this');
2284  # lots of code
2285  $Test->todo_start('working on that');
2286  # more code
2287  $Test->todo_end;
2288  $Test->todo_end;
2289
2290 This is generally not recommended, but large testing systems often have weird
2291 internal needs.
2292
2293 We've tried to make this also work with the TODO: syntax, but it's not
2294 guaranteed and its use is also discouraged:
2295
2296  TODO: {
2297      local $TODO = 'We have work to do!';
2298      $Test->todo_start('working on this');
2299      # lots of code
2300      $Test->todo_start('working on that');
2301      # more code
2302      $Test->todo_end;
2303      $Test->todo_end;
2304  }
2305
2306 Pick one style or another of "TODO" to be on the safe side.
2307
2308 =cut
2309
2310 sub todo_start {
2311     my $self = shift;
2312     my $message = @_ ? shift : '';
2313
2314     $self->{Start_Todo}++;
2315     if( $self->in_todo ) {
2316         push @{ $self->{Todo_Stack} } => $self->todo;
2317     }
2318     $self->{Todo} = $message;
2319
2320     return;
2321 }
2322
2323 =item C<todo_end>
2324
2325  $Test->todo_end;
2326
2327 Stops running tests as "TODO" tests.  This method is fatal if called without a
2328 preceding C<todo_start> method call.
2329
2330 =cut
2331
2332 sub todo_end {
2333     my $self = shift;
2334
2335     if( !$self->{Start_Todo} ) {
2336         $self->croak('todo_end() called without todo_start()');
2337     }
2338
2339     $self->{Start_Todo}--;
2340
2341     if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
2342         $self->{Todo} = pop @{ $self->{Todo_Stack} };
2343     }
2344     else {
2345         delete $self->{Todo};
2346     }
2347
2348     return;
2349 }
2350
2351 =item B<caller>
2352
2353     my $package = $Test->caller;
2354     my($pack, $file, $line) = $Test->caller;
2355     my($pack, $file, $line) = $Test->caller($height);
2356
2357 Like the normal C<caller()>, except it reports according to your C<level()>.
2358
2359 C<$height> will be added to the C<level()>.
2360
2361 If C<caller()> winds up off the top of the stack it report the highest context.
2362
2363 =cut
2364
2365 sub caller {    ## no critic (Subroutines::ProhibitBuiltinHomonyms)
2366     my( $self, $height ) = @_;
2367     $height ||= 0;
2368
2369     my $level = $self->level + $height + 1;
2370     my @caller;
2371     do {
2372         @caller = CORE::caller( $level );
2373         $level--;
2374     } until @caller;
2375     return wantarray ? @caller : $caller[0];
2376 }
2377
2378 =back
2379
2380 =cut
2381
2382 =begin _private
2383
2384 =over 4
2385
2386 =item B<_sanity_check>
2387
2388   $self->_sanity_check();
2389
2390 Runs a bunch of end of test sanity checks to make sure reality came
2391 through ok.  If anything is wrong it will die with a fairly friendly
2392 error message.
2393
2394 =cut
2395
2396 #'#
2397 sub _sanity_check {
2398     my $self = shift;
2399
2400     $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
2401     $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
2402         'Somehow you got a different number of results than tests ran!' );
2403
2404     return;
2405 }
2406
2407 =item B<_whoa>
2408
2409   $self->_whoa($check, $description);
2410
2411 A sanity check, similar to C<assert()>.  If the C<$check> is true, something
2412 has gone horribly wrong.  It will die with the given C<$description> and
2413 a note to contact the author.
2414
2415 =cut
2416
2417 sub _whoa {
2418     my( $self, $check, $desc ) = @_;
2419     if($check) {
2420         local $Level = $Level + 1;
2421         $self->croak(<<"WHOA");
2422 WHOA!  $desc
2423 This should never happen!  Please contact the author immediately!
2424 WHOA
2425     }
2426
2427     return;
2428 }
2429
2430 =item B<_my_exit>
2431
2432   _my_exit($exit_num);
2433
2434 Perl seems to have some trouble with exiting inside an C<END> block.
2435 5.6.1 does some odd things.  Instead, this function edits C<$?>
2436 directly.  It should B<only> be called from inside an C<END> block.
2437 It doesn't actually exit, that's your job.
2438
2439 =cut
2440
2441 sub _my_exit {
2442     $? = $_[0];    ## no critic (Variables::RequireLocalizedPunctuationVars)
2443
2444     return 1;
2445 }
2446
2447 =back
2448
2449 =end _private
2450
2451 =cut
2452
2453 sub _ending {
2454     my $self = shift;
2455     return if $self->no_ending;
2456     return if $self->{Ending}++;
2457
2458     my $real_exit_code = $?;
2459
2460     # Don't bother with an ending if this is a forked copy.  Only the parent
2461     # should do the ending.
2462     if( $self->{Original_Pid} != $$ ) {
2463         return;
2464     }
2465
2466     # Ran tests but never declared a plan or hit done_testing
2467     if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
2468         $self->is_passing(0);
2469         $self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
2470
2471         if($real_exit_code) {
2472             $self->diag(<<"FAIL");
2473 Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
2474 FAIL
2475             $self->is_passing(0);
2476             _my_exit($real_exit_code) && return;
2477         }
2478
2479         # But if the tests ran, handle exit code.
2480         my $test_results = $self->{Test_Results};
2481         if(@$test_results) {
2482             my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
2483             if ($num_failed > 0) {
2484
2485                 my $exit_code = $num_failed <= 254 ? $num_failed : 254;
2486                 _my_exit($exit_code) && return;
2487             }
2488         }
2489         _my_exit(254) && return;
2490     }
2491
2492     # Exit if plan() was never called.  This is so "require Test::Simple"
2493     # doesn't puke.
2494     if( !$self->{Have_Plan} ) {
2495         return;
2496     }
2497
2498     # Don't do an ending if we bailed out.
2499     if( $self->{Bailed_Out} ) {
2500         $self->is_passing(0);
2501         return;
2502     }
2503     # Figure out if we passed or failed and print helpful messages.
2504     my $test_results = $self->{Test_Results};
2505     if(@$test_results) {
2506         # The plan?  We have no plan.
2507         if( $self->{No_Plan} ) {
2508             $self->_output_plan($self->{Curr_Test}) unless $self->no_header;
2509             $self->{Expected_Tests} = $self->{Curr_Test};
2510         }
2511
2512         # Auto-extended arrays and elements which aren't explicitly
2513         # filled in with a shared reference will puke under 5.8.0
2514         # ithreads.  So we have to fill them in by hand. :(
2515         my $empty_result = &share( {} );
2516         for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
2517             $test_results->[$idx] = $empty_result
2518               unless defined $test_results->[$idx];
2519         }
2520
2521         my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
2522
2523         my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
2524
2525         if( $num_extra != 0 ) {
2526             my $s = $self->{Expected_Tests} == 1 ? '' : 's';
2527             $self->diag(<<"FAIL");
2528 Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}.
2529 FAIL
2530             $self->is_passing(0);
2531         }
2532
2533         if($num_failed) {
2534             my $num_tests = $self->{Curr_Test};
2535             my $s = $num_failed == 1 ? '' : 's';
2536
2537             my $qualifier = $num_extra == 0 ? '' : ' run';
2538
2539             $self->diag(<<"FAIL");
2540 Looks like you failed $num_failed test$s of $num_tests$qualifier.
2541 FAIL
2542             $self->is_passing(0);
2543         }
2544
2545         if($real_exit_code) {
2546             $self->diag(<<"FAIL");
2547 Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
2548 FAIL
2549             $self->is_passing(0);
2550             _my_exit($real_exit_code) && return;
2551         }
2552
2553         my $exit_code;
2554         if($num_failed) {
2555             $exit_code = $num_failed <= 254 ? $num_failed : 254;
2556         }
2557         elsif( $num_extra != 0 ) {
2558             $exit_code = 255;
2559         }
2560         else {
2561             $exit_code = 0;
2562         }
2563
2564         _my_exit($exit_code) && return;
2565     }
2566     elsif( $self->{Skip_All} ) {
2567         _my_exit(0) && return;
2568     }
2569     elsif($real_exit_code) {
2570         $self->diag(<<"FAIL");
2571 Looks like your test exited with $real_exit_code before it could output anything.
2572 FAIL
2573         $self->is_passing(0);
2574         _my_exit($real_exit_code) && return;
2575     }
2576     else {
2577         $self->diag("No tests run!\n");
2578         $self->is_passing(0);
2579         _my_exit(255) && return;
2580     }
2581
2582     $self->is_passing(0);
2583     $self->_whoa( 1, "We fell off the end of _ending()" );
2584 }
2585
2586 END {
2587     $Test->_ending if defined $Test;
2588 }
2589
2590 =head1 EXIT CODES
2591
2592 If all your tests passed, Test::Builder will exit with zero (which is
2593 normal).  If anything failed it will exit with how many failed.  If
2594 you run less (or more) tests than you planned, the missing (or extras)
2595 will be considered failures.  If no tests were ever run Test::Builder
2596 will throw a warning and exit with 255.  If the test died, even after
2597 having successfully completed all its tests, it will still be
2598 considered a failure and will exit with 255.
2599
2600 So the exit codes are...
2601
2602     0                   all tests successful
2603     255                 test died or all passed but wrong # of tests run
2604     any other number    how many failed (including missing or extras)
2605
2606 If you fail more than 254 tests, it will be reported as 254.
2607
2608 =head1 THREADS
2609
2610 In perl 5.8.1 and later, Test::Builder is thread-safe.  The test
2611 number is shared amongst all threads.  This means if one thread sets
2612 the test number using C<current_test()> they will all be effected.
2613
2614 While versions earlier than 5.8.1 had threads they contain too many
2615 bugs to support.
2616
2617 Test::Builder is only thread-aware if threads.pm is loaded I<before>
2618 Test::Builder.
2619
2620 =head1 MEMORY
2621
2622 An informative hash, accessible via C<details()>, is stored for each
2623 test you perform.  So memory usage will scale linearly with each test
2624 run. Although this is not a problem for most test suites, it can
2625 become an issue if you do large (hundred thousands to million)
2626 combinatorics tests in the same run.
2627
2628 In such cases, you are advised to either split the test file into smaller
2629 ones, or use a reverse approach, doing "normal" (code) compares and
2630 triggering C<fail()> should anything go unexpected.
2631
2632 Future versions of Test::Builder will have a way to turn history off.
2633
2634
2635 =head1 EXAMPLES
2636
2637 CPAN can provide the best examples.  L<Test::Simple>, L<Test::More>,
2638 L<Test::Exception> and L<Test::Differences> all use Test::Builder.
2639
2640 =head1 SEE ALSO
2641
2642 L<Test::Simple>, L<Test::More>, L<Test::Harness>
2643
2644 =head1 AUTHORS
2645
2646 Original code by chromatic, maintained by Michael G Schwern
2647 E<lt>schwern@pobox.comE<gt>
2648
2649 =head1 MAINTAINERS
2650
2651 =over 4
2652
2653 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
2654
2655 =back
2656
2657 =head1 COPYRIGHT
2658
2659 Copyright 2002-2008 by chromatic E<lt>chromatic@wgz.orgE<gt> and
2660                        Michael G Schwern E<lt>schwern@pobox.comE<gt>.
2661
2662 This program is free software; you can redistribute it and/or
2663 modify it under the same terms as Perl itself.
2664
2665 See F<http://www.perl.com/perl/misc/Artistic.html>
2666
2667 =cut
2668
2669 1;
2670