5 # $^C was only introduced in 5.005-ish. We do this to prevent
6 # use of uninitialized value warnings in older perls.
10 use vars qw($VERSION);
12 $VERSION = eval $VERSION; # make the alpha version come out as a number
14 # Make Test::Builder thread-safe for ithreads.
17 # Load threads::shared when threads are turned on
18 if( $] >= 5.008 && $Config{useithreads} && $INC{'threads.pm'}) {
19 require threads::shared;
21 # Hack around YET ANOTHER threads::shared bug. It would
22 # occassionally forget the contents of the variable when sharing it.
23 # So we first copy the data, then share, then put our copy back.
24 *share = sub (\[$@%]) {
28 if( $type eq 'HASH' ) {
31 elsif( $type eq 'ARRAY' ) {
34 elsif( $type eq 'SCALAR' ) {
38 die "Unknown type: ".$type;
41 $_[0] = &threads::shared::share($_[0]);
43 if( $type eq 'HASH' ) {
46 elsif( $type eq 'ARRAY' ) {
49 elsif( $type eq 'SCALAR' ) {
53 die "Unknown type: ".$type;
59 # 5.8.0's threads::shared is busted when threads are off.
62 *share = sub { return $_[0] };
70 Test::Builder - Backend for building test libraries
74 package My::Test::Module;
80 my $Test = Test::Builder->new;
81 $Test->output('my_logfile');
87 $Test->exported_to($pack);
90 $self->export_to_level(1, $self, 'ok');
94 my($test, $name) = @_;
96 $Test->ok($test, $name);
102 Test::Simple and Test::More have proven to be popular testing modules,
103 but they're not always flexible enough. Test::Builder provides the a
104 building block upon which to write your own test libraries I<which can
113 my $Test = Test::Builder->new;
115 Returns a Test::Builder object representing the current state of the
118 Since you only run one test per program, there is B<one and only one>
119 Test::Builder object. No matter how many times you call new(), you're
120 getting the same object. (This is called a singleton).
124 my $Test = Test::Builder->new;
127 $Test ||= bless ['Move along, nothing to see here'], $class;
135 Reinitializes the Test::Builder singleton to its original state.
136 Mostly useful for tests run in persistent environments where the same
137 test might be run multiple times in the same process.
144 my $Curr_Test; share($Curr_Test);
147 my @Test_Results; share(@Test_Results);
156 my($No_Header, $No_Ending);
171 $Exported_To = undef;
178 ($No_Header, $No_Ending) = (0,0);
180 $self->_dup_stdhandles unless $^C;
187 =head2 Setting up tests
189 These methods are for setting up tests and declaring how many there
190 are. You usually only want to call one of these methods.
196 my $pack = $Test->exported_to;
197 $Test->exported_to($pack);
199 Tells Test::Builder what package you exported your functions to.
200 This is important for getting TODO tests right.
205 my($self, $pack) = @_;
207 if( defined $pack ) {
208 $Exported_To = $pack;
215 $Test->plan('no_plan');
216 $Test->plan( skip_all => $reason );
217 $Test->plan( tests => $num_tests );
219 A convenient way to set up your tests. Call this and Test::Builder
220 will print the appropriate headers and take the appropriate actions.
222 If you call plan(), don't call any of the other methods below.
227 my($self, $cmd, $arg) = @_;
232 die sprintf "You tried to plan twice! Second plan at %s line %d\n",
233 ($self->caller)[1,2];
236 if( $cmd eq 'no_plan' ) {
239 elsif( $cmd eq 'skip_all' ) {
240 return $self->skip_all($arg);
242 elsif( $cmd eq 'tests' ) {
244 return $self->expected_tests($arg);
246 elsif( !defined $arg ) {
247 die "Got an undefined number of tests. Looks like you tried to ".
248 "say how many tests you plan to run but made a mistake.\n";
251 die "You said to run 0 tests! You've got to run something.\n";
256 my @args = grep { defined } ($cmd, $arg);
257 Carp::croak("plan() doesn't understand @args");
263 =item B<expected_tests>
265 my $max = $Test->expected_tests;
266 $Test->expected_tests($max);
268 Gets/sets the # of tests we expect this test to run and prints out
269 the appropriate headers.
278 die "Number of tests must be a postive integer. You gave it '$max'.\n"
279 unless $max =~ /^\+?\d+$/ and $max > 0;
281 $Expected_Tests = $max;
284 $self->_print("1..$max\n") unless $self->no_header;
286 return $Expected_Tests;
294 Declares that this test will run an indeterminate # of tests.
305 $plan = $Test->has_plan
307 Find out whether a plan has been defined. $plan is either C<undef> (no plan has been set), C<no_plan> (indeterminate # of tests) or an integer (the number of expected tests).
312 return($Expected_Tests) if $Expected_Tests;
313 return('no_plan') if $No_Plan;
321 $Test->skip_all($reason);
323 Skips all the tests, using the given $reason. Exits immediately with 0.
328 my($self, $reason) = @_;
331 $out .= " # Skip $reason" if $reason;
336 $self->_print($out) unless $self->no_header;
344 These actually run the tests, analogous to the functions in
347 $name is always optional.
353 $Test->ok($test, $name);
355 Your basic test. Pass if $test is true, fail if $test is false. Just
356 like Test::Simple's ok().
361 my($self, $test, $name) = @_;
363 # $test might contain an object which we don't want to accidentally
364 # store, so we turn it into a boolean.
365 $test = $test ? 1 : 0;
367 unless( $Have_Plan ) {
369 Carp::croak("You tried to run a test without a plan! Gotta have a plan.");
375 # In case $name is a string overloaded object, force it to stringify.
376 $self->_unoverload(\$name);
378 $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
379 You named your test '$name'. You shouldn't use numbers for your test names.
383 my($pack, $file, $line) = $self->caller;
385 my $todo = $self->todo($pack);
386 $self->_unoverload(\$todo);
389 my $result = &share({});
393 @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
396 @$result{ 'ok', 'actual_ok' } = ( 1, $test );
400 $out .= " $Curr_Test" if $self->use_numbers;
402 if( defined $name ) {
403 $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
405 $result->{name} = $name;
408 $result->{name} = '';
412 $out .= " # TODO $todo";
413 $result->{reason} = $todo;
414 $result->{type} = 'todo';
417 $result->{reason} = '';
418 $result->{type} = '';
421 $Test_Results[$Curr_Test-1] = $result;
427 my $msg = $todo ? "Failed (TODO)" : "Failed";
428 $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
429 $self->diag(" $msg test ($file at line $line)\n");
432 return $test ? 1 : 0;
441 eval { require overload } || return;
443 foreach my $thing (@_) {
445 if( defined $$thing ) {
446 if( my $string_meth = overload::Method($$thing, '""') ) {
447 $$thing = $$thing->$string_meth();
457 $Test->is_eq($got, $expected, $name);
459 Like Test::More's is(). Checks if $got eq $expected. This is the
464 $Test->is_num($got, $expected, $name);
466 Like Test::More's is(). Checks if $got == $expected. This is the
472 my($self, $got, $expect, $name) = @_;
473 local $Level = $Level + 1;
475 if( !defined $got || !defined $expect ) {
476 # undef only matches undef and nothing else
477 my $test = !defined $got && !defined $expect;
479 $self->ok($test, $name);
480 $self->_is_diag($got, 'eq', $expect) unless $test;
484 return $self->cmp_ok($got, 'eq', $expect, $name);
488 my($self, $got, $expect, $name) = @_;
489 local $Level = $Level + 1;
491 if( !defined $got || !defined $expect ) {
492 # undef only matches undef and nothing else
493 my $test = !defined $got && !defined $expect;
495 $self->ok($test, $name);
496 $self->_is_diag($got, '==', $expect) unless $test;
500 return $self->cmp_ok($got, '==', $expect, $name);
504 my($self, $got, $type, $expect) = @_;
506 foreach my $val (\$got, \$expect) {
507 if( defined $$val ) {
508 if( $type eq 'eq' ) {
509 # quote and force string context
513 # force numeric context
522 return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
531 $Test->isnt_eq($got, $dont_expect, $name);
533 Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
538 $Test->is_num($got, $dont_expect, $name);
540 Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
546 my($self, $got, $dont_expect, $name) = @_;
547 local $Level = $Level + 1;
549 if( !defined $got || !defined $dont_expect ) {
550 # undef only matches undef and nothing else
551 my $test = defined $got || defined $dont_expect;
553 $self->ok($test, $name);
554 $self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
558 return $self->cmp_ok($got, 'ne', $dont_expect, $name);
562 my($self, $got, $dont_expect, $name) = @_;
563 local $Level = $Level + 1;
565 if( !defined $got || !defined $dont_expect ) {
566 # undef only matches undef and nothing else
567 my $test = defined $got || defined $dont_expect;
569 $self->ok($test, $name);
570 $self->_cmp_diag($got, '!=', $dont_expect) unless $test;
574 return $self->cmp_ok($got, '!=', $dont_expect, $name);
580 $Test->like($this, qr/$regex/, $name);
581 $Test->like($this, '/$regex/', $name);
583 Like Test::More's like(). Checks if $this matches the given $regex.
585 You'll want to avoid qr// if you want your tests to work before 5.005.
589 $Test->unlike($this, qr/$regex/, $name);
590 $Test->unlike($this, '/$regex/', $name);
592 Like Test::More's unlike(). Checks if $this B<does not match> the
598 my($self, $this, $regex, $name) = @_;
600 local $Level = $Level + 1;
601 $self->_regex_ok($this, $regex, '=~', $name);
605 my($self, $this, $regex, $name) = @_;
607 local $Level = $Level + 1;
608 $self->_regex_ok($this, $regex, '!~', $name);
613 $Test->maybe_regex(qr/$regex/);
614 $Test->maybe_regex('/$regex/');
616 Convenience method for building testing functions that take regular
617 expressions as arguments, but need to work before perl 5.005.
619 Takes a quoted regular expression produced by qr//, or a string
620 representing a regular expression.
622 Returns a Perl value which may be used instead of the corresponding
623 regular expression, or undef if it's argument is not recognised.
625 For example, a version of like(), sans the useful diagnostic messages,
629 my ($self, $this, $regex, $name) = @_;
630 my $usable_regex = $self->maybe_regex($regex);
631 die "expecting regex, found '$regex'\n"
632 unless $usable_regex;
633 $self->ok($this =~ m/$usable_regex/, $name);
640 my ($self, $regex) = @_;
641 my $usable_regex = undef;
643 return $usable_regex unless defined $regex;
648 if( ref $regex eq 'Regexp' ) {
649 $usable_regex = $regex;
651 # Check for '/foo/' or 'm,foo,'
652 elsif( ($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
653 (undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
656 $usable_regex = length $opts ? "(?$opts)$re" : $re;
659 return $usable_regex;
663 my($self, $this, $regex, $cmp, $name) = @_;
665 local $Level = $Level + 1;
668 my $usable_regex = $self->maybe_regex($regex);
669 unless (defined $usable_regex) {
670 $ok = $self->ok( 0, $name );
671 $self->diag(" '$regex' doesn't look much like a regex to me.");
677 my $test = $this =~ /$usable_regex/ ? 1 : 0;
678 $test = !$test if $cmp eq '!~';
679 $ok = $self->ok( $test, $name );
683 $this = defined $this ? "'$this'" : 'undef';
684 my $match = $cmp eq '=~' ? "doesn't match" : "matches";
685 $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
697 $Test->cmp_ok($this, $type, $that, $name);
699 Works just like Test::More's cmp_ok().
701 $Test->cmp_ok($big_num, '!=', $other_big_num);
706 my($self, $got, $type, $expect, $name) = @_;
711 local($@,$!); # don't interfere with $@
712 # eval() sometimes resets $!
713 $test = eval "\$got $type \$expect";
715 local $Level = $Level + 1;
716 my $ok = $self->ok($test, $name);
719 if( $type =~ /^(eq|==)$/ ) {
720 $self->_is_diag($got, $type, $expect);
723 $self->_cmp_diag($got, $type, $expect);
730 my($self, $got, $type, $expect) = @_;
732 $got = defined $got ? "'$got'" : 'undef';
733 $expect = defined $expect ? "'$expect'" : 'undef';
734 return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
743 $Test->BAILOUT($reason);
745 Indicates to the Test::Harness that things are going so badly all
746 testing should terminate. This includes running any additional test
749 It will exit with 255.
754 my($self, $reason) = @_;
756 $self->_print("Bail out! $reason");
765 Skips the current test, reporting $why.
770 my($self, $why) = @_;
772 $self->_unoverload(\$why);
774 unless( $Have_Plan ) {
776 Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
782 $Test_Results[$Curr_Test-1] = &share({
791 $out .= " $Curr_Test" if $self->use_numbers;
793 $out .= " $why" if length $why;
805 $Test->todo_skip($why);
807 Like skip(), only it will declare the test as failing and TODO. Similar
810 print "not ok $tnum # TODO $why\n";
815 my($self, $why) = @_;
818 unless( $Have_Plan ) {
820 Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
826 $Test_Results[$Curr_Test-1] = &share({
835 $out .= " $Curr_Test" if $self->use_numbers;
836 $out .= " # TODO & SKIP $why\n";
844 =begin _unimplemented
849 $Test->skip_rest($reason);
851 Like skip(), only it skips all the rest of the tests you plan to run
852 and terminates the test.
854 If you're running under no_plan, it skips once and terminates the
868 $Test->level($how_high);
870 How far up the call stack should $Test look when reporting where the
875 Setting $Test::Builder::Level overrides. This is typically useful
879 local $Test::Builder::Level = 2;
886 my($self, $level) = @_;
888 if( defined $level ) {
897 $Test->use_numbers($on_or_off);
899 Whether or not the test should output numbers. That is, this if true:
911 Most useful when you can't depend on the test output order, such as
912 when threads or forking is involved.
914 Test::Harness will accept either, but avoid mixing the two styles.
921 my($self, $use_nums) = @_;
923 if( defined $use_nums ) {
924 $Use_Nums = $use_nums;
931 $Test->no_header($no_header);
933 If set to true, no "1..N" header will be printed.
937 $Test->no_ending($no_ending);
939 Normally, Test::Builder does some extra diagnostics when the test
940 ends. It also changes the exit code as described below.
942 If this is true, none of that will be done.
947 my($self, $no_header) = @_;
949 if( defined $no_header ) {
950 $No_Header = $no_header;
956 my($self, $no_ending) = @_;
958 if( defined $no_ending ) {
959 $No_Ending = $no_ending;
969 Controlling where the test output goes.
971 It's ok for your test to change where STDOUT and STDERR point to,
972 Test::Builder's default output settings will not be affected.
980 Prints out the given @msgs. Like C<print>, arguments are simply
983 Normally, it uses the failure_output() handle, but if this is for a
984 TODO test, the todo_output() handle is used.
986 Output will be indented and marked with a # so as not to interfere
987 with test output. A newline will be put on the end if there isn't one
990 We encourage using this rather than calling print directly.
992 Returns false. Why? Because diag() is often used in conjunction with
993 a failing test (C<ok() || diag()>) it "passes through" the failure.
995 return ok(...) || diag(...);
998 Mark Fowler <mark@twoshortplanks.com>
1003 my($self, @msgs) = @_;
1004 return unless @msgs;
1006 # Prevent printing headers when compiling (i.e. -c)
1009 # Smash args together like print does.
1010 # Convert undef to 'undef' so its readable.
1011 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1013 # Escape each line with a #.
1016 # Stick a newline on the end if it needs it.
1017 $msg .= "\n" unless $msg =~ /\n\Z/;
1019 local $Level = $Level + 1;
1020 $self->_print_diag($msg);
1029 $Test->_print(@msgs);
1031 Prints to the output() filehandle.
1038 my($self, @msgs) = @_;
1040 # Prevent printing headers when only compiling. Mostly for when
1041 # tests are deparsed with B::Deparse
1044 my $msg = join '', @msgs;
1046 local($\, $", $,) = (undef, ' ', '');
1047 my $fh = $self->output;
1049 # Escape each line after the first with a # so we don't
1050 # confuse Test::Harness.
1051 $msg =~ s/\n(.)/\n# $1/sg;
1053 # Stick a newline on the end if it needs it.
1054 $msg .= "\n" unless $msg =~ /\n\Z/;
1060 =item B<_print_diag>
1062 $Test->_print_diag(@msg);
1064 Like _print, but prints to the current diagnostic filehandle.
1071 local($\, $", $,) = (undef, ' ', '');
1072 my $fh = $self->todo ? $self->todo_output : $self->failure_output;
1079 $Test->output($file);
1081 Where normal "ok/not ok" test output should go.
1085 =item B<failure_output>
1087 $Test->failure_output($fh);
1088 $Test->failure_output($file);
1090 Where diagnostic output on test failures and diag() should go.
1094 =item B<todo_output>
1096 $Test->todo_output($fh);
1097 $Test->todo_output($file);
1099 Where diagnostics about todo test failures and diag() should go.
1105 my($Out_FH, $Fail_FH, $Todo_FH);
1107 my($self, $fh) = @_;
1110 $Out_FH = _new_fh($fh);
1115 sub failure_output {
1116 my($self, $fh) = @_;
1119 $Fail_FH = _new_fh($fh);
1125 my($self, $fh) = @_;
1128 $Todo_FH = _new_fh($fh);
1135 my($file_or_fh) = shift;
1138 if( _is_fh($file_or_fh) ) {
1142 $fh = do { local *FH };
1143 open $fh, ">$file_or_fh" or
1144 die "Can't open test output log $file_or_fh: $!";
1152 my $maybe_fh = shift;
1154 return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
1156 return UNIVERSAL::isa($maybe_fh, 'GLOB') ||
1157 UNIVERSAL::isa($maybe_fh, 'IO::Handle') ||
1159 # 5.5.4's tied() and can() doesn't like getting undef
1160 UNIVERSAL::can((tied($maybe_fh) || ''), 'TIEHANDLE');
1166 my $old_fh = select $fh;
1172 my $Opened_Testhandles = 0;
1173 sub _dup_stdhandles {
1176 $self->_open_testhandles unless $Opened_Testhandles;
1178 # Set everything to unbuffered else plain prints to STDOUT will
1179 # come out in the wrong order from our own prints.
1180 _autoflush(\*TESTOUT);
1181 _autoflush(\*STDOUT);
1182 _autoflush(\*TESTERR);
1183 _autoflush(\*STDERR);
1185 $Test->output(\*TESTOUT);
1186 $Test->failure_output(\*TESTERR);
1187 $Test->todo_output(\*TESTOUT);
1190 sub _open_testhandles {
1191 # We dup STDOUT and STDERR so people can change them in their
1192 # test suites while still getting normal test output.
1193 open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
1194 open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
1195 $Opened_Testhandles = 1;
1202 =head2 Test Status and Info
1206 =item B<current_test>
1208 my $curr_test = $Test->current_test;
1209 $Test->current_test($num);
1211 Gets/sets the current test number we're on. You usually shouldn't
1214 If set forward, the details of the missing tests are filled in as 'unknown'.
1215 if set backward, the details of the intervening tests are deleted. You
1216 can erase history if you really want to.
1221 my($self, $num) = @_;
1224 if( defined $num ) {
1225 unless( $Have_Plan ) {
1227 Carp::croak("Can't change the current test number without a plan!");
1232 # If the test counter is being pushed forward fill in the details.
1233 if( $num > @Test_Results ) {
1234 my $start = @Test_Results ? $#Test_Results + 1 : 0;
1235 for ($start..$num-1) {
1236 $Test_Results[$_] = &share({
1239 reason => 'incrementing test number',
1245 # If backward, wipe history. Its their funeral.
1246 elsif( $num < @Test_Results ) {
1247 $#Test_Results = $num - 1;
1256 my @tests = $Test->summary;
1258 A simple summary of the tests so far. True for pass, false for fail.
1259 This is a logical pass/fail, so todos are passes.
1261 Of course, test #1 is $tests[0], etc...
1268 return map { $_->{'ok'} } @Test_Results;
1273 my @tests = $Test->details;
1275 Like summary(), but with a lot more detail.
1277 $tests[$test_num - 1] =
1278 { 'ok' => is the test considered a pass?
1279 actual_ok => did it literally say 'ok'?
1280 name => name of the test (if any)
1281 type => type of test (if any, see below).
1282 reason => reason for the above (if any)
1285 'ok' is true if Test::Harness will consider the test to be a pass.
1287 'actual_ok' is a reflection of whether or not the test literally
1288 printed 'ok' or 'not ok'. This is for examining the result of 'todo'
1291 'name' is the name of the test.
1293 'type' indicates if it was a special test. Normal tests have a type
1294 of ''. Type can be one of the following:
1298 todo_skip see todo_skip()
1301 Sometimes the Test::Builder test counter is incremented without it
1302 printing any test output, for example, when current_test() is changed.
1303 In these cases, Test::Builder doesn't know the result of the test, so
1304 it's type is 'unkown'. These details for these tests are filled in.
1305 They are considered ok, but the name and actual_ok is left undef.
1307 For example "not ok 23 - hole count # TODO insufficient donuts" would
1308 result in this structure:
1310 $tests[22] = # 23 - 1, since arrays start from 0.
1311 { ok => 1, # logically, the test passed since it's todo
1312 actual_ok => 0, # in absolute terms, it failed
1313 name => 'hole count',
1315 reason => 'insufficient donuts'
1321 return @Test_Results;
1326 my $todo_reason = $Test->todo;
1327 my $todo_reason = $Test->todo($pack);
1329 todo() looks for a $TODO variable in your tests. If set, all tests
1330 will be considered 'todo' (see Test::More and Test::Harness for
1331 details). Returns the reason (ie. the value of $TODO) if running as
1332 todo tests, false otherwise.
1334 todo() is pretty part about finding the right package to look for
1335 $TODO in. It uses the exported_to() package to find it. If that's
1336 not set, it's pretty good at guessing the right package to look at.
1338 Sometimes there is some confusion about where todo() should be looking
1339 for the $TODO variable. If you want to be sure, tell it explicitly
1345 my($self, $pack) = @_;
1347 $pack = $pack || $self->exported_to || $self->caller(1);
1350 return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
1356 my $package = $Test->caller;
1357 my($pack, $file, $line) = $Test->caller;
1358 my($pack, $file, $line) = $Test->caller($height);
1360 Like the normal caller(), except it reports according to your level().
1365 my($self, $height) = @_;
1368 my @caller = CORE::caller($self->level + $height + 1);
1369 return wantarray ? @caller : $caller[0];
1380 =item B<_sanity_check>
1384 Runs a bunch of end of test sanity checks to make sure reality came
1385 through ok. If anything is wrong it will die with a fairly friendly
1392 _whoa($Curr_Test < 0, 'Says here you ran a negative number of tests!');
1393 _whoa(!$Have_Plan and $Curr_Test,
1394 'Somehow your tests ran without a plan!');
1395 _whoa($Curr_Test != @Test_Results,
1396 'Somehow you got a different number of results than tests ran!');
1401 _whoa($check, $description);
1403 A sanity check, similar to assert(). If the $check is true, something
1404 has gone horribly wrong. It will die with the given $description and
1405 a note to contact the author.
1410 my($check, $desc) = @_;
1414 This should never happen! Please contact the author immediately!
1421 _my_exit($exit_num);
1423 Perl seems to have some trouble with exiting inside an END block. 5.005_03
1424 and 5.6.1 both seem to do odd things. Instead, this function edits $?
1425 directly. It should ONLY be called from inside an END block. It
1426 doesn't actually exit, that's your job.
1443 $SIG{__DIE__} = sub {
1444 # We don't want to muck with death in an eval, but $^S isn't
1445 # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
1446 # with it. Instead, we use caller. This also means it runs under
1449 for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) {
1450 $in_eval = 1 if $sub =~ /^\(eval\)/;
1452 $Test_Died = 1 unless $in_eval;
1460 # Don't bother with an ending if this is a forked copy. Only the parent
1461 # should do the ending.
1462 do{ _my_exit($?) && return } if $Original_Pid != $$;
1464 # Bailout if plan() was never called. This is so
1465 # "require Test::Simple" doesn't puke.
1466 do{ _my_exit(0) && return } if !$Have_Plan && !$Test_Died;
1468 # Figure out if we passed or failed and print helpful messages.
1469 if( @Test_Results ) {
1470 # The plan? We have no plan.
1472 $self->_print("1..$Curr_Test\n") unless $self->no_header;
1473 $Expected_Tests = $Curr_Test;
1476 # Auto-extended arrays and elements which aren't explicitly
1477 # filled in with a shared reference will puke under 5.8.0
1478 # ithreads. So we have to fill them in by hand. :(
1479 my $empty_result = &share({});
1480 for my $idx ( 0..$Expected_Tests-1 ) {
1481 $Test_Results[$idx] = $empty_result
1482 unless defined $Test_Results[$idx];
1485 my $num_failed = grep !$_->{'ok'}, @Test_Results[0..$Expected_Tests-1];
1486 $num_failed += abs($Expected_Tests - @Test_Results);
1488 if( $Curr_Test < $Expected_Tests ) {
1489 my $s = $Expected_Tests == 1 ? '' : 's';
1490 $self->diag(<<"FAIL");
1491 Looks like you planned $Expected_Tests test$s but only ran $Curr_Test.
1494 elsif( $Curr_Test > $Expected_Tests ) {
1495 my $num_extra = $Curr_Test - $Expected_Tests;
1496 my $s = $Expected_Tests == 1 ? '' : 's';
1497 $self->diag(<<"FAIL");
1498 Looks like you planned $Expected_Tests test$s but ran $num_extra extra.
1501 elsif ( $num_failed ) {
1502 my $s = $num_failed == 1 ? '' : 's';
1503 $self->diag(<<"FAIL");
1504 Looks like you failed $num_failed test$s of $Expected_Tests.
1509 $self->diag(<<"FAIL");
1510 Looks like your test died just after $Curr_Test.
1513 _my_exit( 255 ) && return;
1516 _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return;
1518 elsif ( $Skip_All ) {
1519 _my_exit( 0 ) && return;
1521 elsif ( $Test_Died ) {
1522 $self->diag(<<'FAIL');
1523 Looks like your test died before it could output anything.
1525 _my_exit( 255 ) && return;
1528 $self->diag("No tests run!\n");
1529 _my_exit( 255 ) && return;
1534 $Test->_ending if defined $Test and !$Test->no_ending;
1539 If all your tests passed, Test::Builder will exit with zero (which is
1540 normal). If anything failed it will exit with how many failed. If
1541 you run less (or more) tests than you planned, the missing (or extras)
1542 will be considered failures. If no tests were ever run Test::Builder
1543 will throw a warning and exit with 255. If the test died, even after
1544 having successfully completed all its tests, it will still be
1545 considered a failure and will exit with 255.
1547 So the exit codes are...
1549 0 all tests successful
1551 any other number how many failed (including missing or extras)
1553 If you fail more than 254 tests, it will be reported as 254.
1558 In perl 5.8.0 and later, Test::Builder is thread-safe. The test
1559 number is shared amongst all threads. This means if one thread sets
1560 the test number using current_test() they will all be effected.
1562 Test::Builder is only thread-aware if threads.pm is loaded I<before>
1567 CPAN can provide the best examples. Test::Simple, Test::More,
1568 Test::Exception and Test::Differences all use Test::Builder.
1572 Test::Simple, Test::More, Test::Harness
1576 Original code by chromatic, maintained by Michael G Schwern
1577 E<lt>schwern@pobox.comE<gt>
1581 Copyright 2002, 2004 by chromatic E<lt>chromatic@wgz.orgE<gt> and
1582 Michael G Schwern E<lt>schwern@pobox.comE<gt>.
1584 This program is free software; you can redistribute it and/or
1585 modify it under the same terms as Perl itself.
1587 See F<http://www.perl.com/perl/misc/Artistic.html>