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