8 $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
12 require Test::Builder::IO::Scalar;
17 # Make Test::Builder thread-safe for ithreads.
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;
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 (\[$@%]) {
32 if( $type eq 'HASH' ) {
35 elsif( $type eq 'ARRAY' ) {
38 elsif( $type eq 'SCALAR' ) {
42 die( "Unknown type: " . $type );
45 $_[0] = &threads::shared::share( $_[0] );
47 if( $type eq 'HASH' ) {
50 elsif( $type eq 'ARRAY' ) {
53 elsif( $type eq 'SCALAR' ) {
57 die( "Unknown type: " . $type );
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.
66 *share = sub { return $_[0] };
73 Test::Builder - Backend for building test libraries
77 package My::Test::Module;
78 use base 'Test::Builder::Module';
80 my $CLASS = __PACKAGE__;
83 my($test, $name) = @_;
84 my $tb = $CLASS->builder;
86 $tb->ok($test, $name);
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
103 my $Test = Test::Builder->new;
105 Returns a Test::Builder object representing the current state of the
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.
114 If you want a completely new Test::Builder object different from the
115 singleton, use C<create>.
119 our $Test = Test::Builder->new;
123 $Test ||= $class->create;
129 my $Test = Test::Builder->create;
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>.
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.
144 my $self = bless {}, $class;
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.
155 my($src, $dest) = @_;
166 my $child = $builder->child($name_of_child);
167 $child->plan( tests => 4 );
168 $child->ok(some_code());
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.
176 Trying to create a new child with a previous child still active (i.e.,
177 C<finalize> not called) will C<croak>.
179 Trying to run a test when you have an open child will also C<croak> and cause
180 the test suite to fail.
185 my( $self, $name ) = @_;
187 if( $self->{Child_Name} ) {
188 $self->croak("You already have a child named ($self->{Child_Name}) running");
191 my $parent_in_todo = $self->in_todo;
193 # Clear $TODO for the child.
194 my $orig_TODO = $self->find_TODO(undef, 1, undef);
196 my $class = ref $self;
197 my $child = $class->create;
199 # Add to our indentation
200 $child->_indent( $self->_indent . ' ' );
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 );
207 # Ensure the child understands if they're inside a TODO
208 if( $parent_in_todo ) {
209 $child->failure_output( $self->todo_output );
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} = $?;
216 $child->{Parent} = $self;
217 $child->{Parent_TODO} = $orig_TODO;
218 $child->{Name} = $name || "Child of " . $self->name;
219 $self->{Child_Name} = $child->name;
226 $builder->subtest($name, \&subtests);
228 See documentation of C<subtest> in Test::More.
234 my($name, $subtests) = @_;
236 if ('CODE' ne ref $subtests) {
237 $self->croak("subtest()'s second argument must be a code ref");
240 # Turn the child into the parent so anyone who has stored a copy of
241 # the Test::Builder singleton will get the child.
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;
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);
255 my $run_the_subtests = sub {
256 # Add subtest name for clarification of starting point
257 $self->note("Subtest: $name");
259 $self->done_testing unless $self->_plan_handled;
263 if( !eval { $run_the_subtests->() } ) {
268 # Restore the parent and the copied child.
269 _copy($self, $child);
270 _copy($parent, $self);
272 # Restore the parent's $TODO
273 $self->find_TODO(undef, 1, $child->{Parent_TODO});
275 # Die *after* we restore the parent.
276 die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
278 local $Test::Builder::Level = $Test::Builder::Level + 1;
279 my $finalize = $child->finalize;
281 $self->BAIL_OUT($child->{Bailed_Out_Reason}) if $child->{Bailed_Out};
288 =item B<_plan_handled>
290 if ( $Test->_plan_handled ) { ... }
292 Returns true if the developer has explicitly handled the plan via:
296 =item * Explicitly setting the number of tests
298 =item * Setting 'no_plan'
300 =item * Set 'skip_all'.
304 This is currently used in subtests when we implicitly call C<< $Test->done_testing >>
305 if the developer has not set a plan.
313 return $self->{Have_Plan} || $self->{No_Plan} || $self->{Skip_All};
319 my $ok = $child->finalize;
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.
324 Calling finalize on a child with open children will C<croak>.
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.
329 No attempt to call methods on a child after C<finalize> is called is
330 guaranteed to succeed.
332 Calling this on the root builder is a no-op.
339 return unless $self->parent;
340 if( $self->{Child_Name} ) {
341 $self->croak("Can't call finalize() with child ($self->{Child_Name}) active");
344 local $? = 0; # don't fail if $subtests happened to set $? nonzero
347 # XXX This will only be necessary for TAP envelopes (we think)
348 #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );
350 local $Test::Builder::Level = $Test::Builder::Level + 1;
352 $self->parent->{Child_Name} = undef;
353 unless ($self->{Bailed_Out}) {
354 if ( $self->{Skip_All} ) {
355 $self->parent->skip($self->{Skip_All});
357 elsif ( not @{ $self->{Test_Results} } ) {
358 $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name );
361 $self->parent->ok( $self->is_passing, $self->name );
364 $? = $self->{Child_Error};
365 delete $self->{Parent};
367 return $self->is_passing;
374 $self->{Indent} = shift;
377 return $self->{Indent};
382 if ( my $parent = $builder->parent ) {
386 Returns the parent C<Test::Builder> instance, if any. Only used with child
387 builders for nested TAP.
391 sub parent { shift->{Parent} }
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".
403 sub name { shift->{Name} }
407 if ( $self->parent and $$ == $self->{Original_Pid} ) {
408 my $name = $self->name;
409 $self->diag(<<"FAIL");
410 Child ($name) exited without calling finalize()
412 $self->parent->{In_Destroy} = 1;
413 $self->parent->ok(0, $name);
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.
429 sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
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.
437 $self->is_passing(1);
439 $self->{Have_Plan} = 0;
440 $self->{No_Plan} = 0;
441 $self->{Have_Output_Plan} = 0;
442 $self->{Done_Testing} = 0;
444 $self->{Original_Pid} = $$;
445 $self->{Child_Name} = undef;
446 $self->{Indent} ||= '';
448 $self->{Curr_Test} = 0;
449 $self->{Test_Results} = &share( [] );
451 $self->{Exported_To} = undef;
452 $self->{Expected_Tests} = 0;
454 $self->{Skip_All} = 0;
456 $self->{Use_Nums} = 1;
458 $self->{No_Header} = 0;
459 $self->{No_Ending} = 0;
461 $self->{Todo} = undef;
462 $self->{Todo_Stack} = [];
463 $self->{Start_Todo} = 0;
464 $self->{Opened_Testhandles} = 0;
467 $self->_dup_stdhandles;
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.
479 share( $self->{Curr_Test} );
487 =head2 Setting up tests
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.
496 $Test->plan('no_plan');
497 $Test->plan( skip_all => $reason );
498 $Test->plan( tests => $num_tests );
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.
503 If you call C<plan()>, don't call any of the other methods below.
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
509 my $child = $Test->child('some child');
510 eval { $child->plan( $condition ? ( skip_all => $reason ) : ( tests => 3 ) ) };
511 if ( eval { $@->isa('Test::Builder::Exception') } ) {
520 no_plan => \&no_plan,
521 skip_all => \&skip_all,
522 tests => \&_plan_tests,
526 my( $self, $cmd, $arg ) = @_;
530 local $Level = $Level + 1;
532 $self->croak("You tried to plan twice") if $self->{Have_Plan};
534 if( my $method = $plan_cmds{$cmd} ) {
535 local $Level = $Level + 1;
536 $self->$method($arg);
539 my @args = grep { defined } ( $cmd, $arg );
540 $self->croak("plan() doesn't understand @args");
548 my($self, $arg) = @_;
551 local $Level = $Level + 1;
552 return $self->expected_tests($arg);
554 elsif( !defined $arg ) {
555 $self->croak("Got an undefined number of tests");
558 $self->croak("You said to run 0 tests");
564 =item B<expected_tests>
566 my $max = $Test->expected_tests;
567 $Test->expected_tests($max);
569 Gets/sets the number of tests we expect this test to run and prints out
570 the appropriate headers.
579 $self->croak("Number of tests must be a positive integer. You gave it '$max'")
580 unless $max =~ /^\+?\d+$/;
582 $self->{Expected_Tests} = $max;
583 $self->{Have_Plan} = 1;
585 $self->_output_plan($max) unless $self->no_header;
587 return $self->{Expected_Tests};
594 Declares that this test will run an indeterminate number of tests.
599 my($self, $arg) = @_;
601 $self->carp("no_plan takes no arguments") if $arg;
603 $self->{No_Plan} = 1;
604 $self->{Have_Plan} = 1;
611 =item B<_output_plan>
613 $tb->_output_plan($max);
614 $tb->_output_plan($max, $directive);
615 $tb->_output_plan($max, $directive => $reason);
617 Handles displaying the test plan.
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:
622 $tb->_output_plan(0, "SKIP", "Because I said so");
624 It sets C<< $tb->{Have_Output_Plan} >> and will croak if the plan was already
632 my($self, $max, $directive, $reason) = @_;
634 $self->carp("The plan was already output") if $self->{Have_Output_Plan};
636 my $plan = "1..$max";
637 $plan .= " # $directive" if defined $directive;
638 $plan .= " $reason" if defined $reason;
640 $self->_print("$plan\n");
642 $self->{Have_Output_Plan} = 1;
648 =item B<done_testing>
650 $Test->done_testing();
651 $Test->done_testing($num_tests);
653 Declares that you are done testing, no more tests will be run after this point.
655 If a plan has not yet been output, it will do so.
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,
662 If C<done_testing()> is called twice, the second call will issue a
665 If C<$num_tests> is omitted, the number of tests run will be used, like
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:
672 $Test->done_testing();
674 Or to plan a variable number of tests:
676 for my $test (@tests) {
679 $Test->done_testing(scalar @tests);
684 my($self, $num_tests) = @_;
686 # If done_testing() specified the number of tests, shut off no_plan.
687 if( defined $num_tests ) {
688 $self->{No_Plan} = 0;
691 $num_tests = $self->current_test;
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");
700 $self->{Done_Testing} = [caller];
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");
707 $self->{Expected_Tests} = $num_tests;
710 $self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
712 $self->{Have_Plan} = 1;
714 # The wrong number of tests were run
715 $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test};
718 $self->is_passing(0) if $self->{Curr_Test} == 0;
726 $plan = $Test->has_plan
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
737 return( $self->{Expected_Tests} ) if $self->{Expected_Tests};
738 return('no_plan') if $self->{No_Plan};
745 $Test->skip_all($reason);
747 Skips all the tests, using the given C<$reason>. Exits immediately with 0.
752 my( $self, $reason ) = @_;
754 $self->{Skip_All} = $self->parent ? $reason : 1;
756 $self->_output_plan(0, "SKIP", $reason) unless $self->no_header;
757 if ( $self->parent ) {
758 die bless {} => 'Test::Builder::Exception';
765 my $pack = $Test->exported_to;
766 $Test->exported_to($pack);
768 Tells Test::Builder what package you exported your functions to.
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.
777 my( $self, $pack ) = @_;
779 if( defined $pack ) {
780 $self->{Exported_To} = $pack;
782 return $self->{Exported_To};
789 These actually run the tests, analogous to the functions in Test::More.
791 They all return true if the test passed, false if the test failed.
793 C<$name> is always optional.
799 $Test->ok($test, $name);
801 Your basic test. Pass if C<$test> is true, fail if $test is false. Just
802 like Test::Simple's C<ok()>.
807 my( $self, $test, $name ) = @_;
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");
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;
818 lock $self->{Curr_Test};
819 $self->{Curr_Test}++;
821 # In case $name is a string overloaded object, force it to stringify.
822 $self->_unoverload_str( \$name );
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.
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;
835 $self->_unoverload_str( \$todo );
838 my $result = &share( {} );
842 @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
845 @$result{ 'ok', 'actual_ok' } = ( 1, $test );
849 $out .= " $self->{Curr_Test}" if $self->use_numbers;
851 if( defined $name ) {
852 $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
854 $result->{name} = $name;
857 $result->{name} = '';
860 if( $self->in_todo ) {
861 $out .= " # TODO $todo";
862 $result->{reason} = $todo;
863 $result->{type} = 'todo';
866 $result->{reason} = '';
867 $result->{type} = '';
870 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
876 my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
877 $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
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]);
885 $self->diag(qq[ $msg test at $file line $line.\n]);
889 $self->is_passing(0) unless $test || $self->in_todo;
891 # Check that we haven't violated the plan
892 $self->_check_is_passing_plan();
894 return $test ? 1 : 0;
898 # Check that we haven't yet violated the plan and set
899 # is_passing() accordingly
900 sub _check_is_passing_plan {
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};
914 $self->_try(sub { require overload; }, die_on_fail => 1);
916 foreach my $thing (@_) {
917 if( $self->_is_object($$thing) ) {
918 if( my $string_meth = overload::Method( $$thing, $type ) ) {
919 $$thing = $$thing->$string_meth();
928 my( $self, $thing ) = @_;
930 return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
933 sub _unoverload_str {
936 return $self->_unoverload( q[""], @_ );
939 sub _unoverload_num {
942 $self->_unoverload( '0+', @_ );
945 next unless $self->_is_dualvar($$val);
952 # This is a hack to detect a dualvar such as $!
954 my( $self, $val ) = @_;
956 # Objects are not dualvars.
957 return 0 if ref $val;
959 no warnings 'numeric';
960 my $numval = $val + 0;
961 return ($numval != 0 and $numval ne $val ? 1 : 0);
966 $Test->is_eq($got, $expected, $name);
968 Like Test::More's C<is()>. Checks if C<$got eq $expected>. This is the
971 C<undef> only ever matches another C<undef>.
975 $Test->is_num($got, $expected, $name);
977 Like Test::More's C<is()>. Checks if C<$got == $expected>. This is the
980 C<undef> only ever matches another C<undef>.
985 my( $self, $got, $expect, $name ) = @_;
986 local $Level = $Level + 1;
988 if( !defined $got || !defined $expect ) {
989 # undef only matches undef and nothing else
990 my $test = !defined $got && !defined $expect;
992 $self->ok( $test, $name );
993 $self->_is_diag( $got, 'eq', $expect ) unless $test;
997 return $self->cmp_ok( $got, 'eq', $expect, $name );
1001 my( $self, $got, $expect, $name ) = @_;
1002 local $Level = $Level + 1;
1004 if( !defined $got || !defined $expect ) {
1005 # undef only matches undef and nothing else
1006 my $test = !defined $got && !defined $expect;
1008 $self->ok( $test, $name );
1009 $self->_is_diag( $got, '==', $expect ) unless $test;
1013 return $self->cmp_ok( $got, '==', $expect, $name );
1017 my( $self, $type, $val ) = @_;
1019 if( defined $$val ) {
1020 if( $type eq 'eq' or $type eq 'ne' ) {
1021 # quote and force string context
1025 # force numeric context
1026 $self->_unoverload_num($val);
1037 my( $self, $got, $type, $expect ) = @_;
1039 $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
1041 local $Level = $Level + 1;
1042 return $self->diag(<<"DIAGNOSTIC");
1050 my( $self, $got, $type ) = @_;
1052 $self->_diag_fmt( $type, \$got );
1054 local $Level = $Level + 1;
1055 return $self->diag(<<"DIAGNOSTIC");
1057 expected: anything else
1063 $Test->isnt_eq($got, $dont_expect, $name);
1065 Like Test::More's C<isnt()>. Checks if C<$got ne $dont_expect>. This is
1070 $Test->isnt_num($got, $dont_expect, $name);
1072 Like Test::More's C<isnt()>. Checks if C<$got ne $dont_expect>. This is
1073 the numeric version.
1078 my( $self, $got, $dont_expect, $name ) = @_;
1079 local $Level = $Level + 1;
1081 if( !defined $got || !defined $dont_expect ) {
1082 # undef only matches undef and nothing else
1083 my $test = defined $got || defined $dont_expect;
1085 $self->ok( $test, $name );
1086 $self->_isnt_diag( $got, 'ne' ) unless $test;
1090 return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
1094 my( $self, $got, $dont_expect, $name ) = @_;
1095 local $Level = $Level + 1;
1097 if( !defined $got || !defined $dont_expect ) {
1098 # undef only matches undef and nothing else
1099 my $test = defined $got || defined $dont_expect;
1101 $self->ok( $test, $name );
1102 $self->_isnt_diag( $got, '!=' ) unless $test;
1106 return $self->cmp_ok( $got, '!=', $dont_expect, $name );
1111 $Test->like($thing, qr/$regex/, $name);
1112 $Test->like($thing, '/$regex/', $name);
1114 Like Test::More's C<like()>. Checks if $thing matches the given C<$regex>.
1118 $Test->unlike($thing, qr/$regex/, $name);
1119 $Test->unlike($thing, '/$regex/', $name);
1121 Like Test::More's C<unlike()>. Checks if $thing B<does not match> the
1127 my( $self, $thing, $regex, $name ) = @_;
1129 local $Level = $Level + 1;
1130 return $self->_regex_ok( $thing, $regex, '=~', $name );
1134 my( $self, $thing, $regex, $name ) = @_;
1136 local $Level = $Level + 1;
1137 return $self->_regex_ok( $thing, $regex, '!~', $name );
1142 $Test->cmp_ok($thing, $type, $that, $name);
1144 Works just like Test::More's C<cmp_ok()>.
1146 $Test->cmp_ok($big_num, '!=', $other_big_num);
1150 my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
1152 # Bad, these are not comparison operators. Should we include more?
1153 my %cmp_ok_bl = map { ( $_, 1 ) } ( "=", "+=", ".=", "x=", "^=", "|=", "||=", "&&=", "...");
1156 my( $self, $got, $type, $expect, $name ) = @_;
1158 if ($cmp_ok_bl{$type}) {
1159 $self->croak("$type is not a valid comparison operator in cmp_ok()");
1165 ## no critic (BuiltinFunctions::ProhibitStringyEval)
1167 local( $@, $!, $SIG{__DIE__} ); # isolate eval
1169 my($pack, $file, $line) = $self->caller();
1171 # This is so that warnings come out at the caller's level
1173 #line $line "(eval in cmp_ok) $file"
1174 \$got $type \$expect;
1178 local $Level = $Level + 1;
1179 my $ok = $self->ok( $test, $name );
1181 # Treat overloaded objects as numbers if we're asked to do a
1182 # numeric comparison.
1184 = $numeric_cmps{$type}
1186 : '_unoverload_str';
1188 $self->diag(<<"END") if $error;
1189 An error occurred while using $type:
1190 ------------------------------------
1192 ------------------------------------
1196 $self->$unoverload( \$got, \$expect );
1198 if( $type =~ /^(eq|==)$/ ) {
1199 $self->_is_diag( $got, $type, $expect );
1201 elsif( $type =~ /^(ne|!=)$/ ) {
1202 $self->_isnt_diag( $got, $type );
1205 $self->_cmp_diag( $got, $type, $expect );
1212 my( $self, $got, $type, $expect ) = @_;
1214 $got = defined $got ? "'$got'" : 'undef';
1215 $expect = defined $expect ? "'$expect'" : 'undef';
1217 local $Level = $Level + 1;
1218 return $self->diag(<<"DIAGNOSTIC");
1225 sub _caller_context {
1228 my( $pack, $file, $line ) = $self->caller(1);
1231 $code .= "#line $line $file\n" if defined $file and defined $line;
1239 =head2 Other Testing Methods
1241 These are methods which are used in the course of writing a test but are not themselves tests.
1247 $Test->BAIL_OUT($reason);
1249 Indicates to the Test::Harness that things are going so badly all
1250 testing should terminate. This includes running any additional test
1253 It will exit with 255.
1258 my( $self, $reason ) = @_;
1260 $self->{Bailed_Out} = 1;
1262 if ($self->parent) {
1263 $self->{Bailed_Out_Reason} = $reason;
1264 $self->no_ending(1);
1265 die bless {} => 'Test::Builder::Exception';
1268 $self->_print("Bail out! $reason");
1273 BAIL_OUT() used to be BAILOUT()
1279 *BAILOUT = \&BAIL_OUT;
1287 Skips the current test, reporting C<$why>.
1292 my( $self, $why ) = @_;
1294 $self->_unoverload_str( \$why );
1296 lock( $self->{Curr_Test} );
1297 $self->{Curr_Test}++;
1299 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
1310 $out .= " $self->{Curr_Test}" if $self->use_numbers;
1312 $out .= " $why" if length $why;
1315 $self->_print($out);
1323 $Test->todo_skip($why);
1325 Like C<skip()>, only it will declare the test as failing and TODO. Similar
1328 print "not ok $tnum # TODO $why\n";
1333 my( $self, $why ) = @_;
1336 lock( $self->{Curr_Test} );
1337 $self->{Curr_Test}++;
1339 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
1344 type => 'todo_skip',
1350 $out .= " $self->{Curr_Test}" if $self->use_numbers;
1351 $out .= " # TODO & SKIP $why\n";
1353 $self->_print($out);
1358 =begin _unimplemented
1363 $Test->skip_rest($reason);
1365 Like C<skip()>, only it skips all the rest of the tests you plan to run
1366 and terminates the test.
1368 If you're running under C<no_plan>, it skips once and terminates the
1376 =head2 Test building utility methods
1378 These methods are useful when writing your own test methods.
1382 =item B<maybe_regex>
1384 $Test->maybe_regex(qr/$regex/);
1385 $Test->maybe_regex('/$regex/');
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.
1390 Convenience method for building testing functions that take regular
1391 expressions as arguments.
1393 Takes a quoted regular expression produced by C<qr//>, or a string
1394 representing a regular expression.
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.
1399 For example, a version of C<like()>, sans the useful diagnostic messages,
1400 could be written as:
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);
1413 my( $self, $regex ) = @_;
1414 my $usable_regex = undef;
1416 return $usable_regex unless defined $regex;
1421 if( _is_qr($regex) ) {
1422 $usable_regex = $regex;
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
1429 $usable_regex = length $opts ? "(?$opts)$re" : $re;
1432 return $usable_regex;
1438 # is_regexp() checks for regexes in a robust manner, say if they're
1440 return re::is_regexp($regex) if defined &re::is_regexp;
1441 return ref $regex eq 'Regexp';
1445 my( $self, $thing, $regex, $cmp, $name ) = @_;
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.");
1458 my $context = $self->_caller_context;
1461 ## no critic (BuiltinFunctions::ProhibitStringyEval)
1463 local( $@, $!, $SIG{__DIE__} ); # isolate eval
1465 # No point in issuing an uninit warning, they'll see it in the diagnostics
1466 no warnings 'uninitialized';
1468 $test = eval $context . q{$test = $thing =~ /$usable_regex/ ? 1 : 0};
1471 $test = !$test if $cmp eq '!~';
1473 local $Level = $Level + 1;
1474 $ok = $self->ok( $test, $name );
1478 $thing = defined $thing ? "'$thing'" : 'undef';
1479 my $match = $cmp eq '=~' ? "doesn't match" : "matches";
1481 local $Level = $Level + 1;
1482 $self->diag( sprintf <<'DIAGNOSTIC', $thing, $match, $regex );
1492 # I'm not ready to publish this. It doesn't deal with array return
1493 # values from the code or context.
1499 my $return_from_code = $Test->try(sub { code });
1500 my($return_from_code, $error) = $Test->try(sub { code });
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
1507 C<$error> is what would normally be in C<$@>.
1509 It is suggested you use this in place of eval BLOCK.
1514 my( $self, $code, %opts ) = @_;
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->() };
1526 die $error if $error and $opts{die_on_fail};
1528 return wantarray ? ( $return, $error ) : $return;
1536 my $is_fh = $Test->is_fh($thing);
1538 Determines if the given C<$thing> can be used as a filehandle.
1544 my $maybe_fh = shift;
1545 return 0 unless defined $maybe_fh;
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
1550 return eval { $maybe_fh->isa("IO::Handle") } ||
1551 eval { tied($maybe_fh)->can('TIEHANDLE') };
1564 $Test->level($how_high);
1566 How far up the call stack should C<$Test> look when reporting where the
1571 Setting L<$Test::Builder::Level> overrides. This is typically useful
1577 local $Test::Builder::Level = $Test::Builder::Level + 1;
1581 To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant.
1586 my( $self, $level ) = @_;
1588 if( defined $level ) {
1594 =item B<use_numbers>
1596 $Test->use_numbers($on_or_off);
1598 Whether or not the test should output numbers. That is, this if true:
1610 Most useful when you can't depend on the test output order, such as
1611 when threads or forking is involved.
1618 my( $self, $use_nums ) = @_;
1620 if( defined $use_nums ) {
1621 $self->{Use_Nums} = $use_nums;
1623 return $self->{Use_Nums};
1628 $Test->no_diag($no_diag);
1630 If set true no diagnostics will be printed. This includes calls to
1635 $Test->no_ending($no_ending);
1637 Normally, Test::Builder does some extra diagnostics when the test
1638 ends. It also changes the exit code as described below.
1640 If this is true, none of that will be done.
1644 $Test->no_header($no_header);
1646 If set to true, no "1..N" header will be printed.
1650 foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
1651 my $method = lc $attribute;
1654 my( $self, $no ) = @_;
1657 $self->{$attribute} = $no;
1659 return $self->{$attribute};
1662 no strict 'refs'; ## no critic
1663 *{ __PACKAGE__ . '::' . $method } = $code;
1670 Controlling where the test output goes.
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.
1681 Prints out the given C<@msgs>. Like C<print>, arguments are simply
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.
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
1691 We encourage using this rather than calling print directly.
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.
1696 return ok(...) || diag(...);
1699 Mark Fowler <mark@twoshortplanks.com>
1706 $self->_print_comment( $self->_diag_fh, @_ );
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.
1721 $self->_print_comment( $self->output, @_ );
1727 local $Level = $Level + 1;
1728 return $self->in_todo ? $self->todo_output : $self->failure_output;
1731 sub _print_comment {
1732 my( $self, $fh, @msgs ) = @_;
1734 return if $self->no_diag;
1735 return unless @msgs;
1737 # Prevent printing headers when compiling (i.e. -c)
1740 # Smash args together like print does.
1741 # Convert undef to 'undef' so its readable.
1742 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1744 # Escape the beginning, _print will take care of the rest.
1747 local $Level = $Level + 1;
1748 $self->_print_to_fh( $fh, $msg );
1755 my @dump = $Test->explain(@msgs);
1757 Will dump the contents of any references in a human readable format.
1758 Handy for things like...
1760 is_deeply($have, $want) || diag explain $have;
1764 is_deeply($have, $want) || note explain $have;
1774 $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
1776 my $dumper = Data::Dumper->new( [$_] );
1777 $dumper->Indent(1)->Terse(1);
1778 $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
1789 $Test->_print(@msgs);
1791 Prints to the C<output()> filehandle.
1799 return $self->_print_to_fh( $self->output, @_ );
1803 my( $self, $fh, @msgs ) = @_;
1805 # Prevent printing headers when only compiling. Mostly for when
1806 # tests are deparsed with B::Deparse
1809 my $msg = join '', @msgs;
1810 my $indent = $self->_indent;
1812 local( $\, $", $, ) = ( undef, ' ', '' );
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;
1818 # Stick a newline on the end if it needs it.
1819 $msg .= "\n" unless $msg =~ /\n\z/;
1821 return print $fh $indent, $msg;
1826 =item B<failure_output>
1828 =item B<todo_output>
1830 my $filehandle = $Test->output;
1831 $Test->output($filehandle);
1832 $Test->output($filename);
1833 $Test->output(\$scalar);
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>.
1839 B<output> is where normal "ok/not ok" test output goes.
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.
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
1858 my( $self, $fh ) = @_;
1861 $self->{Out_FH} = $self->_new_fh($fh);
1863 return $self->{Out_FH};
1866 sub failure_output {
1867 my( $self, $fh ) = @_;
1870 $self->{Fail_FH} = $self->_new_fh($fh);
1872 return $self->{Fail_FH};
1876 my( $self, $fh ) = @_;
1879 $self->{Todo_FH} = $self->_new_fh($fh);
1881 return $self->{Todo_FH};
1886 my($file_or_fh) = shift;
1889 if( $self->is_fh($file_or_fh) ) {
1892 elsif( ref $file_or_fh eq 'SCALAR' ) {
1893 # Scalar refs as filehandles was added in 5.8.
1895 open $fh, ">>", $file_or_fh
1896 or $self->croak("Can't open scalar ref $file_or_fh: $!");
1898 # Emulate scalar ref filehandles with a tie.
1900 $fh = Test::Builder::IO::Scalar->new($file_or_fh)
1901 or $self->croak("Can't tie scalar ref $file_or_fh");
1905 open $fh, ">", $file_or_fh
1906 or $self->croak("Can't open test output log $file_or_fh: $!");
1915 my $old_fh = select $fh;
1922 my( $Testout, $Testerr );
1924 sub _dup_stdhandles {
1927 $self->_open_testhandles;
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 );
1936 $self->reset_outputs;
1941 sub _open_testhandles {
1944 return if $self->{Opened_Testhandles};
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: $!";
1951 $self->_copy_io_layers( \*STDOUT, $Testout );
1952 $self->_copy_io_layers( \*STDERR, $Testerr );
1954 $self->{Opened_Testhandles} = 1;
1959 sub _copy_io_layers {
1960 my( $self, $src, $dst ) = @_;
1965 my @src_layers = PerlIO::get_layers($src);
1967 _apply_layers($dst, @src_layers) if @src_layers;
1975 my ($fh, @layers) = @_;
1977 my @unique = grep { $_ ne 'unix' and !$seen{$_}++ } @layers;
1978 binmode($fh, join(":", "", "raw", @unique));
1986 Resets all the output filehandles back to their defaults.
1993 $self->output ($Testout);
1994 $self->failure_output($Testerr);
1995 $self->todo_output ($Testout);
2002 $tb->carp(@message);
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 >>).
2009 $tb->croak(@message);
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 >>).
2016 sub _message_at_caller {
2019 local $Level = $Level + 1;
2020 my( $pack, $file, $line ) = $self->caller;
2021 return join( "", @_ ) . " at $file line $line.\n";
2026 return warn $self->_message_at_caller(@_);
2031 return die $self->_message_at_caller(@_);
2038 =head2 Test Status and Info
2042 =item B<current_test>
2044 my $curr_test = $Test->current_test;
2045 $Test->current_test($num);
2047 Gets/sets the current test number we're on. You usually shouldn't
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.
2057 my( $self, $num ) = @_;
2059 lock( $self->{Curr_Test} );
2060 if( defined $num ) {
2061 $self->{Curr_Test} = $num;
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(
2072 reason => 'incrementing test number',
2079 # If backward, wipe history. Its their funeral.
2080 elsif( $num < @$test_results ) {
2081 $#{$test_results} = $num - 1;
2084 return $self->{Curr_Test};
2089 my $ok = $builder->is_passing;
2091 Indicates if the test suite is currently passing.
2093 More formally, it will be false if anything has happened which makes
2094 it impossible for the test suite to pass. True otherwise.
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.
2100 Don't think about it too much.
2108 $self->{Is_Passing} = shift;
2111 return $self->{Is_Passing};
2117 my @tests = $Test->summary;
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.
2122 Of course, test #1 is $tests[0], etc...
2129 return map { $_->{'ok'} } @{ $self->{Test_Results} };
2134 my @tests = $Test->details;
2136 Like C<summary()>, but with a lot more detail.
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)
2146 'ok' is true if Test::Harness will consider the test to be a pass.
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'
2152 'name' is the name of the test.
2154 'type' indicates if it was a special test. Normal tests have a type
2155 of ''. Type can be one of the following:
2159 todo_skip see todo_skip()
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>.
2168 For example "not ok 23 - hole count # TODO insufficient donuts" would
2169 result in this structure:
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',
2176 reason => 'insufficient donuts'
2183 return @{ $self->{Test_Results} };
2188 my $todo_reason = $Test->todo;
2189 my $todo_reason = $Test->todo($pack);
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
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.
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()>.
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
2211 my( $self, $pack ) = @_;
2213 return $self->{Todo} if defined $self->{Todo};
2215 local $Level = $Level + 1;
2216 my $todo = $self->find_TODO($pack);
2217 return $todo if defined $todo;
2224 my $todo_reason = $Test->find_TODO();
2225 my $todo_reason = $Test->find_TODO($pack);
2227 Like C<todo()> but only returns the value of C<$TODO> ignoring
2230 Can also be used to set C<$TODO> to a new value while returning the
2233 my $old_reason = $Test->find_TODO($pack, 1, $new_reason);
2238 my( $self, $pack, $set, $new_value ) = @_;
2240 $pack = $pack || $self->caller(1) || $self->exported_to;
2241 return unless $pack;
2243 no strict 'refs'; ## no critic
2244 my $old_value = ${ $pack . '::TODO' };
2245 $set and ${ $pack . '::TODO' } = $new_value;
2251 my $in_todo = $Test->in_todo;
2253 Returns true if the test is currently inside a TODO block.
2260 local $Level = $Level + 1;
2261 return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
2266 $Test->todo_start();
2267 $Test->todo_start($message);
2269 This method allows you declare all subsequent tests as TODO tests, up until
2270 the C<todo_end> method has been called.
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
2278 Note that you can use this to nest "todo" tests
2280 $Test->todo_start('working on this');
2282 $Test->todo_start('working on that');
2287 This is generally not recommended, but large testing systems often have weird
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:
2294 local $TODO = 'We have work to do!';
2295 $Test->todo_start('working on this');
2297 $Test->todo_start('working on that');
2303 Pick one style or another of "TODO" to be on the safe side.
2309 my $message = @_ ? shift : '';
2311 $self->{Start_Todo}++;
2312 if( $self->in_todo ) {
2313 push @{ $self->{Todo_Stack} } => $self->todo;
2315 $self->{Todo} = $message;
2324 Stops running tests as "TODO" tests. This method is fatal if called without a
2325 preceding C<todo_start> method call.
2332 if( !$self->{Start_Todo} ) {
2333 $self->croak('todo_end() called without todo_start()');
2336 $self->{Start_Todo}--;
2338 if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
2339 $self->{Todo} = pop @{ $self->{Todo_Stack} };
2342 delete $self->{Todo};
2350 my $package = $Test->caller;
2351 my($pack, $file, $line) = $Test->caller;
2352 my($pack, $file, $line) = $Test->caller($height);
2354 Like the normal C<caller()>, except it reports according to your C<level()>.
2356 C<$height> will be added to the C<level()>.
2358 If C<caller()> winds up off the top of the stack it report the highest context.
2362 sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
2363 my( $self, $height ) = @_;
2366 my $level = $self->level + $height + 1;
2369 @caller = CORE::caller( $level );
2372 return wantarray ? @caller : $caller[0];
2383 =item B<_sanity_check>
2385 $self->_sanity_check();
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
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!' );
2406 $self->_whoa($check, $description);
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.
2415 my( $self, $check, $desc ) = @_;
2417 local $Level = $Level + 1;
2418 $self->croak(<<"WHOA");
2420 This should never happen! Please contact the author immediately!
2429 _my_exit($exit_num);
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.
2439 $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
2452 return if $self->no_ending;
2453 return if $self->{Ending}++;
2455 my $real_exit_code = $?;
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} != $$ ) {
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.");
2468 if($real_exit_code) {
2469 $self->diag(<<"FAIL");
2470 Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
2472 $self->is_passing(0);
2473 _my_exit($real_exit_code) && return;
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) {
2482 my $exit_code = $num_failed <= 254 ? $num_failed : 254;
2483 _my_exit($exit_code) && return;
2486 _my_exit(254) && return;
2489 # Exit if plan() was never called. This is so "require Test::Simple"
2491 if( !$self->{Have_Plan} ) {
2495 # Don't do an ending if we bailed out.
2496 if( $self->{Bailed_Out} ) {
2497 $self->is_passing(0);
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};
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];
2518 my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
2520 my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
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}.
2527 $self->is_passing(0);
2531 my $num_tests = $self->{Curr_Test};
2532 my $s = $num_failed == 1 ? '' : 's';
2534 my $qualifier = $num_extra == 0 ? '' : ' run';
2536 $self->diag(<<"FAIL");
2537 Looks like you failed $num_failed test$s of $num_tests$qualifier.
2539 $self->is_passing(0);
2542 if($real_exit_code) {
2543 $self->diag(<<"FAIL");
2544 Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
2546 $self->is_passing(0);
2547 _my_exit($real_exit_code) && return;
2552 $exit_code = $num_failed <= 254 ? $num_failed : 254;
2554 elsif( $num_extra != 0 ) {
2561 _my_exit($exit_code) && return;
2563 elsif( $self->{Skip_All} ) {
2564 _my_exit(0) && return;
2566 elsif($real_exit_code) {
2567 $self->diag(<<"FAIL");
2568 Looks like your test exited with $real_exit_code before it could output anything.
2570 $self->is_passing(0);
2571 _my_exit($real_exit_code) && return;
2574 $self->diag("No tests run!\n");
2575 $self->is_passing(0);
2576 _my_exit(255) && return;
2579 $self->is_passing(0);
2580 $self->_whoa( 1, "We fell off the end of _ending()" );
2584 $Test->_ending if defined $Test;
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.
2597 So the exit codes are...
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)
2603 If you fail more than 254 tests, it will be reported as 254.
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.
2611 While versions earlier than 5.8.1 had threads they contain too many
2614 Test::Builder is only thread-aware if threads.pm is loaded I<before>
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.
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.
2629 Future versions of Test::Builder will have a way to turn history off.
2634 CPAN can provide the best examples. Test::Simple, Test::More,
2635 Test::Exception and Test::Differences all use Test::Builder.
2639 Test::Simple, Test::More, Test::Harness
2643 Original code by chromatic, maintained by Michael G Schwern
2644 E<lt>schwern@pobox.comE<gt>
2648 Copyright 2002-2008 by chromatic E<lt>chromatic@wgz.orgE<gt> and
2649 Michael G Schwern E<lt>schwern@pobox.comE<gt>.
2651 This program is free software; you can redistribute it and/or
2652 modify it under the same terms as Perl itself.
2654 See F<http://www.perl.com/perl/misc/Artistic.html>