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 # 5.8.0's threads are so busted we no longer support them.
19 if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'}) {
20 require threads::shared;
22 # Hack around YET ANOTHER threads::shared bug. It would
23 # occassionally forget the contents of the variable when sharing it.
24 # So we first copy the data, then share, then put our copy back.
25 *share = sub (\[$@%]) {
29 if( $type eq 'HASH' ) {
32 elsif( $type eq 'ARRAY' ) {
35 elsif( $type eq 'SCALAR' ) {
39 die("Unknown type: ".$type);
42 $_[0] = &threads::shared::share($_[0]);
44 if( $type eq 'HASH' ) {
47 elsif( $type eq 'ARRAY' ) {
50 elsif( $type eq 'SCALAR' ) {
54 die("Unknown type: ".$type);
60 # 5.8.0's threads::shared is busted when threads are off
61 # and earlier Perls just don't have that module at all.
63 *share = sub { return $_[0] };
71 Test::Builder - Backend for building test libraries
75 package My::Test::Module;
81 my $Test = Test::Builder->new;
82 $Test->output('my_logfile');
88 $Test->exported_to($pack);
91 $self->export_to_level(1, $self, 'ok');
95 my($test, $name) = @_;
97 $Test->ok($test, $name);
103 Test::Simple and Test::More have proven to be popular testing modules,
104 but they're not always flexible enough. Test::Builder provides the a
105 building block upon which to write your own test libraries I<which can
114 my $Test = Test::Builder->new;
116 Returns a Test::Builder object representing the current state of the
119 Since you only run one test per program C<new> always returns the same
120 Test::Builder object. No matter how many times you call new(), you're
121 getting the same object. This is called a singleton. This is done so that
122 multiple modules share such global information as the test counter and
123 where test output is going.
125 If you want a completely new Test::Builder object different from the
126 singleton, use C<create>.
130 my $Test = Test::Builder->new;
133 $Test ||= $class->create;
140 my $Test = Test::Builder->create;
142 Ok, so there can be more than one Test::Builder object and this is how
143 you get it. You might use this instead of C<new()> if you're testing
144 a Test::Builder based module, but otherwise you probably want C<new>.
146 B<NOTE>: the implementation is not complete. C<level>, for example, is
147 still shared amongst B<all> Test::Builder objects, even ones created using
148 this method. Also, the method name may change in the future.
155 my $self = bless {}, $class;
165 Reinitializes the Test::Builder singleton to its original state.
166 Mostly useful for tests run in persistent environments where the same
167 test might be run multiple times in the same process.
176 # We leave this a global because it has to be localized and localizing
177 # hash keys is just asking for pain. Also, it was documented.
180 $self->{Test_Died} = 0;
181 $self->{Have_Plan} = 0;
182 $self->{No_Plan} = 0;
183 $self->{Original_Pid} = $$;
185 share($self->{Curr_Test});
186 $self->{Curr_Test} = 0;
187 $self->{Test_Results} = &share([]);
189 $self->{Exported_To} = undef;
190 $self->{Expected_Tests} = 0;
192 $self->{Skip_All} = 0;
194 $self->{Use_Nums} = 1;
196 $self->{No_Header} = 0;
197 $self->{No_Ending} = 0;
199 $self->_dup_stdhandles unless $^C;
206 =head2 Setting up tests
208 These methods are for setting up tests and declaring how many there
209 are. You usually only want to call one of these methods.
215 my $pack = $Test->exported_to;
216 $Test->exported_to($pack);
218 Tells Test::Builder what package you exported your functions to.
219 This is important for getting TODO tests right.
224 my($self, $pack) = @_;
226 if( defined $pack ) {
227 $self->{Exported_To} = $pack;
229 return $self->{Exported_To};
234 $Test->plan('no_plan');
235 $Test->plan( skip_all => $reason );
236 $Test->plan( tests => $num_tests );
238 A convenient way to set up your tests. Call this and Test::Builder
239 will print the appropriate headers and take the appropriate actions.
241 If you call plan(), don't call any of the other methods below.
246 my($self, $cmd, $arg) = @_;
250 if( $self->{Have_Plan} ) {
251 $self->croak("You tried to plan twice");
254 if( $cmd eq 'no_plan' ) {
257 elsif( $cmd eq 'skip_all' ) {
258 return $self->skip_all($arg);
260 elsif( $cmd eq 'tests' ) {
262 local $Level = $Level + 1;
263 return $self->expected_tests($arg);
265 elsif( !defined $arg ) {
266 $self->croak("Got an undefined number of tests");
269 $self->croak("You said to run 0 tests");
273 my @args = grep { defined } ($cmd, $arg);
274 $self->croak("plan() doesn't understand @args");
280 =item B<expected_tests>
282 my $max = $Test->expected_tests;
283 $Test->expected_tests($max);
285 Gets/sets the # of tests we expect this test to run and prints out
286 the appropriate headers.
295 $self->croak("Number of tests must be a positive integer. You gave it '$max'")
296 unless $max =~ /^\+?\d+$/ and $max > 0;
298 $self->{Expected_Tests} = $max;
299 $self->{Have_Plan} = 1;
301 $self->_print("1..$max\n") unless $self->no_header;
303 return $self->{Expected_Tests};
311 Declares that this test will run an indeterminate # of tests.
318 $self->{No_Plan} = 1;
319 $self->{Have_Plan} = 1;
324 $plan = $Test->has_plan
326 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).
333 return($self->{Expected_Tests}) if $self->{Expected_Tests};
334 return('no_plan') if $self->{No_Plan};
342 $Test->skip_all($reason);
344 Skips all the tests, using the given $reason. Exits immediately with 0.
349 my($self, $reason) = @_;
352 $out .= " # Skip $reason" if $reason;
355 $self->{Skip_All} = 1;
357 $self->_print($out) unless $self->no_header;
365 These actually run the tests, analogous to the functions in
368 $name is always optional.
374 $Test->ok($test, $name);
376 Your basic test. Pass if $test is true, fail if $test is false. Just
377 like Test::Simple's ok().
382 my($self, $test, $name) = @_;
384 # $test might contain an object which we don't want to accidentally
385 # store, so we turn it into a boolean.
386 $test = $test ? 1 : 0;
390 lock $self->{Curr_Test};
391 $self->{Curr_Test}++;
393 # In case $name is a string overloaded object, force it to stringify.
394 $self->_unoverload_str(\$name);
396 $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
397 You named your test '$name'. You shouldn't use numbers for your test names.
401 my($pack, $file, $line) = $self->caller;
403 my $todo = $self->todo($pack);
404 $self->_unoverload_str(\$todo);
407 my $result = &share({});
411 @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
414 @$result{ 'ok', 'actual_ok' } = ( 1, $test );
418 $out .= " $self->{Curr_Test}" if $self->use_numbers;
420 if( defined $name ) {
421 $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
423 $result->{name} = $name;
426 $result->{name} = '';
430 $out .= " # TODO $todo";
431 $result->{reason} = $todo;
432 $result->{type} = 'todo';
435 $result->{reason} = '';
436 $result->{type} = '';
439 $self->{Test_Results}[$self->{Curr_Test}-1] = $result;
445 my $msg = $todo ? "Failed (TODO)" : "Failed";
446 $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
448 if( defined $name ) {
449 $self->diag(qq[ $msg test '$name'\n]);
450 $self->diag(qq[ at $file line $line.\n]);
453 $self->diag(qq[ $msg test at $file line $line.\n]);
457 return $test ? 1 : 0;
467 eval { require overload } || return;
469 foreach my $thing (@_) {
471 if( _is_object($$thing) ) {
472 if( my $string_meth = overload::Method($$thing, $type) ) {
473 $$thing = $$thing->$string_meth();
484 return eval { ref $thing && $thing->isa('UNIVERSAL') } ? 1 : 0;
488 sub _unoverload_str {
491 $self->_unoverload(q[""], @_);
494 sub _unoverload_num {
497 $self->_unoverload('0+', @_);
500 next unless $self->_is_dualvar($$val);
506 # This is a hack to detect a dualvar such as $!
508 my($self, $val) = @_;
512 return 1 if $numval != 0 and $numval ne $val;
519 $Test->is_eq($got, $expected, $name);
521 Like Test::More's is(). Checks if $got eq $expected. This is the
526 $Test->is_num($got, $expected, $name);
528 Like Test::More's is(). Checks if $got == $expected. This is the
534 my($self, $got, $expect, $name) = @_;
535 local $Level = $Level + 1;
537 $self->_unoverload_str(\$got, \$expect);
539 if( !defined $got || !defined $expect ) {
540 # undef only matches undef and nothing else
541 my $test = !defined $got && !defined $expect;
543 $self->ok($test, $name);
544 $self->_is_diag($got, 'eq', $expect) unless $test;
548 return $self->cmp_ok($got, 'eq', $expect, $name);
552 my($self, $got, $expect, $name) = @_;
553 local $Level = $Level + 1;
555 $self->_unoverload_num(\$got, \$expect);
557 if( !defined $got || !defined $expect ) {
558 # undef only matches undef and nothing else
559 my $test = !defined $got && !defined $expect;
561 $self->ok($test, $name);
562 $self->_is_diag($got, '==', $expect) unless $test;
566 return $self->cmp_ok($got, '==', $expect, $name);
570 my($self, $got, $type, $expect) = @_;
572 foreach my $val (\$got, \$expect) {
573 if( defined $$val ) {
574 if( $type eq 'eq' ) {
575 # quote and force string context
579 # force numeric context
580 $self->_unoverload_num($val);
588 return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
597 $Test->isnt_eq($got, $dont_expect, $name);
599 Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
604 $Test->isnt_num($got, $dont_expect, $name);
606 Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
612 my($self, $got, $dont_expect, $name) = @_;
613 local $Level = $Level + 1;
615 if( !defined $got || !defined $dont_expect ) {
616 # undef only matches undef and nothing else
617 my $test = defined $got || defined $dont_expect;
619 $self->ok($test, $name);
620 $self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
624 return $self->cmp_ok($got, 'ne', $dont_expect, $name);
628 my($self, $got, $dont_expect, $name) = @_;
629 local $Level = $Level + 1;
631 if( !defined $got || !defined $dont_expect ) {
632 # undef only matches undef and nothing else
633 my $test = defined $got || defined $dont_expect;
635 $self->ok($test, $name);
636 $self->_cmp_diag($got, '!=', $dont_expect) unless $test;
640 return $self->cmp_ok($got, '!=', $dont_expect, $name);
646 $Test->like($this, qr/$regex/, $name);
647 $Test->like($this, '/$regex/', $name);
649 Like Test::More's like(). Checks if $this matches the given $regex.
651 You'll want to avoid qr// if you want your tests to work before 5.005.
655 $Test->unlike($this, qr/$regex/, $name);
656 $Test->unlike($this, '/$regex/', $name);
658 Like Test::More's unlike(). Checks if $this B<does not match> the
664 my($self, $this, $regex, $name) = @_;
666 local $Level = $Level + 1;
667 $self->_regex_ok($this, $regex, '=~', $name);
671 my($self, $this, $regex, $name) = @_;
673 local $Level = $Level + 1;
674 $self->_regex_ok($this, $regex, '!~', $name);
679 $Test->maybe_regex(qr/$regex/);
680 $Test->maybe_regex('/$regex/');
682 Convenience method for building testing functions that take regular
683 expressions as arguments, but need to work before perl 5.005.
685 Takes a quoted regular expression produced by qr//, or a string
686 representing a regular expression.
688 Returns a Perl value which may be used instead of the corresponding
689 regular expression, or undef if it's argument is not recognised.
691 For example, a version of like(), sans the useful diagnostic messages,
695 my ($self, $this, $regex, $name) = @_;
696 my $usable_regex = $self->maybe_regex($regex);
697 die "expecting regex, found '$regex'\n"
698 unless $usable_regex;
699 $self->ok($this =~ m/$usable_regex/, $name);
706 my ($self, $regex) = @_;
707 my $usable_regex = undef;
709 return $usable_regex unless defined $regex;
714 if( ref $regex eq 'Regexp' ) {
715 $usable_regex = $regex;
717 # Check for '/foo/' or 'm,foo,'
718 elsif( ($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
719 (undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
722 $usable_regex = length $opts ? "(?$opts)$re" : $re;
725 return $usable_regex;
729 my($self, $this, $regex, $cmp, $name) = @_;
732 my $usable_regex = $self->maybe_regex($regex);
733 unless (defined $usable_regex) {
734 $ok = $self->ok( 0, $name );
735 $self->diag(" '$regex' doesn't look much like a regex to me.");
741 my $code = $self->_caller_context;
745 # Yes, it has to look like this or 5.4.5 won't see the #line directive.
746 # Don't ask me, man, I just work here.
748 $code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
750 $test = !$test if $cmp eq '!~';
752 local $Level = $Level + 1;
753 $ok = $self->ok( $test, $name );
757 $this = defined $this ? "'$this'" : 'undef';
758 my $match = $cmp eq '=~' ? "doesn't match" : "matches";
759 $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
771 $Test->cmp_ok($this, $type, $that, $name);
773 Works just like Test::More's cmp_ok().
775 $Test->cmp_ok($big_num, '!=', $other_big_num);
780 my %numeric_cmps = map { ($_, 1) }
781 ("<", "<=", ">", ">=", "==", "!=", "<=>");
784 my($self, $got, $type, $expect, $name) = @_;
786 # Treat overloaded objects as numbers if we're asked to do a
787 # numeric comparison.
788 my $unoverload = $numeric_cmps{$type} ? '_unoverload_num'
791 $self->$unoverload(\$got, \$expect);
796 local($@,$!); # don't interfere with $@
797 # eval() sometimes resets $!
799 my $code = $self->_caller_context;
801 # Yes, it has to look like this or 5.4.5 won't see the #line directive.
802 # Don't ask me, man, I just work here.
804 $code" . "\$got $type \$expect;";
807 local $Level = $Level + 1;
808 my $ok = $self->ok($test, $name);
811 if( $type =~ /^(eq|==)$/ ) {
812 $self->_is_diag($got, $type, $expect);
815 $self->_cmp_diag($got, $type, $expect);
822 my($self, $got, $type, $expect) = @_;
824 $got = defined $got ? "'$got'" : 'undef';
825 $expect = defined $expect ? "'$expect'" : 'undef';
826 return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
834 sub _caller_context {
837 my($pack, $file, $line) = $self->caller(1);
840 $code .= "#line $line $file\n" if defined $file and defined $line;
848 $Test->BAIL_OUT($reason);
850 Indicates to the Test::Harness that things are going so badly all
851 testing should terminate. This includes running any additional test
854 It will exit with 255.
859 my($self, $reason) = @_;
861 $self->{Bailed_Out} = 1;
862 $self->_print("Bail out! $reason");
867 BAIL_OUT() used to be BAILOUT()
871 *BAILOUT = \&BAIL_OUT;
879 Skips the current test, reporting $why.
884 my($self, $why) = @_;
886 $self->_unoverload_str(\$why);
890 lock($self->{Curr_Test});
891 $self->{Curr_Test}++;
893 $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
902 $out .= " $self->{Curr_Test}" if $self->use_numbers;
904 $out .= " $why" if length $why;
916 $Test->todo_skip($why);
918 Like skip(), only it will declare the test as failing and TODO. Similar
921 print "not ok $tnum # TODO $why\n";
926 my($self, $why) = @_;
931 lock($self->{Curr_Test});
932 $self->{Curr_Test}++;
934 $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
943 $out .= " $self->{Curr_Test}" if $self->use_numbers;
944 $out .= " # TODO & SKIP $why\n";
952 =begin _unimplemented
957 $Test->skip_rest($reason);
959 Like skip(), only it skips all the rest of the tests you plan to run
960 and terminates the test.
962 If you're running under no_plan, it skips once and terminates the
976 $Test->level($how_high);
978 How far up the call stack should $Test look when reporting where the
983 Setting $Test::Builder::Level overrides. This is typically useful
987 local $Test::Builder::Level = 2;
994 my($self, $level) = @_;
996 if( defined $level ) {
1003 =item B<use_numbers>
1005 $Test->use_numbers($on_or_off);
1007 Whether or not the test should output numbers. That is, this if true:
1019 Most useful when you can't depend on the test output order, such as
1020 when threads or forking is involved.
1022 Test::Harness will accept either, but avoid mixing the two styles.
1029 my($self, $use_nums) = @_;
1031 if( defined $use_nums ) {
1032 $self->{Use_Nums} = $use_nums;
1034 return $self->{Use_Nums};
1040 $Test->no_diag($no_diag);
1042 If set true no diagnostics will be printed. This includes calls to
1047 $Test->no_ending($no_ending);
1049 Normally, Test::Builder does some extra diagnostics when the test
1050 ends. It also changes the exit code as described below.
1052 If this is true, none of that will be done.
1056 $Test->no_header($no_header);
1058 If set to true, no "1..N" header will be printed.
1062 foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
1063 my $method = lc $attribute;
1066 my($self, $no) = @_;
1069 $self->{$attribute} = $no;
1071 return $self->{$attribute};
1075 *{__PACKAGE__.'::'.$method} = $code;
1083 Controlling where the test output goes.
1085 It's ok for your test to change where STDOUT and STDERR point to,
1086 Test::Builder's default output settings will not be affected.
1094 Prints out the given @msgs. Like C<print>, arguments are simply
1097 Normally, it uses the failure_output() handle, but if this is for a
1098 TODO test, the todo_output() handle is used.
1100 Output will be indented and marked with a # so as not to interfere
1101 with test output. A newline will be put on the end if there isn't one
1104 We encourage using this rather than calling print directly.
1106 Returns false. Why? Because diag() is often used in conjunction with
1107 a failing test (C<ok() || diag()>) it "passes through" the failure.
1109 return ok(...) || diag(...);
1112 Mark Fowler <mark@twoshortplanks.com>
1117 my($self, @msgs) = @_;
1119 return if $self->no_diag;
1120 return unless @msgs;
1122 # Prevent printing headers when compiling (i.e. -c)
1125 # Smash args together like print does.
1126 # Convert undef to 'undef' so its readable.
1127 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1129 # Escape each line with a #.
1132 # Stick a newline on the end if it needs it.
1133 $msg .= "\n" unless $msg =~ /\n\Z/;
1135 local $Level = $Level + 1;
1136 $self->_print_diag($msg);
1145 $Test->_print(@msgs);
1147 Prints to the output() filehandle.
1154 my($self, @msgs) = @_;
1156 # Prevent printing headers when only compiling. Mostly for when
1157 # tests are deparsed with B::Deparse
1160 my $msg = join '', @msgs;
1162 local($\, $", $,) = (undef, ' ', '');
1163 my $fh = $self->output;
1165 # Escape each line after the first with a # so we don't
1166 # confuse Test::Harness.
1167 $msg =~ s/\n(.)/\n# $1/sg;
1169 # Stick a newline on the end if it needs it.
1170 $msg .= "\n" unless $msg =~ /\n\Z/;
1177 =item B<_print_diag>
1179 $Test->_print_diag(@msg);
1181 Like _print, but prints to the current diagnostic filehandle.
1190 local($\, $", $,) = (undef, ' ', '');
1191 my $fh = $self->todo ? $self->todo_output : $self->failure_output;
1198 $Test->output($file);
1200 Where normal "ok/not ok" test output should go.
1204 =item B<failure_output>
1206 $Test->failure_output($fh);
1207 $Test->failure_output($file);
1209 Where diagnostic output on test failures and diag() should go.
1213 =item B<todo_output>
1215 $Test->todo_output($fh);
1216 $Test->todo_output($file);
1218 Where diagnostics about todo test failures and diag() should go.
1225 my($self, $fh) = @_;
1228 $self->{Out_FH} = $self->_new_fh($fh);
1230 return $self->{Out_FH};
1233 sub failure_output {
1234 my($self, $fh) = @_;
1237 $self->{Fail_FH} = $self->_new_fh($fh);
1239 return $self->{Fail_FH};
1243 my($self, $fh) = @_;
1246 $self->{Todo_FH} = $self->_new_fh($fh);
1248 return $self->{Todo_FH};
1254 my($file_or_fh) = shift;
1257 if( $self->_is_fh($file_or_fh) ) {
1261 $fh = do { local *FH };
1262 open $fh, ">$file_or_fh" or
1263 $self->croak("Can't open test output log $file_or_fh: $!");
1273 my $maybe_fh = shift;
1274 return 0 unless defined $maybe_fh;
1276 return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
1278 return UNIVERSAL::isa($maybe_fh, 'GLOB') ||
1279 UNIVERSAL::isa($maybe_fh, 'IO::Handle') ||
1281 # 5.5.4's tied() and can() doesn't like getting undef
1282 UNIVERSAL::can((tied($maybe_fh) || ''), 'TIEHANDLE');
1288 my $old_fh = select $fh;
1294 sub _dup_stdhandles {
1297 $self->_open_testhandles;
1299 # Set everything to unbuffered else plain prints to STDOUT will
1300 # come out in the wrong order from our own prints.
1301 _autoflush(\*TESTOUT);
1302 _autoflush(\*STDOUT);
1303 _autoflush(\*TESTERR);
1304 _autoflush(\*STDERR);
1306 $self->output(\*TESTOUT);
1307 $self->failure_output(\*TESTERR);
1308 $self->todo_output(\*TESTOUT);
1312 my $Opened_Testhandles = 0;
1313 sub _open_testhandles {
1314 return if $Opened_Testhandles;
1315 # We dup STDOUT and STDERR so people can change them in their
1316 # test suites while still getting normal test output.
1317 open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
1318 open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
1319 $Opened_Testhandles = 1;
1325 $tb->carp(@message);
1327 Warns with C<@message> but the message will appear to come from the
1328 point where the original test function was called (C<$tb->caller>).
1332 $tb->croak(@message);
1334 Dies with C<@message> but the message will appear to come from the
1335 point where the original test function was called (C<$tb->caller>).
1339 sub _message_at_caller {
1342 local $Level = $Level + 2;
1343 my($pack, $file, $line) = $self->caller;
1344 return join("", @_) . " at $file line $line.\n";
1349 warn $self->_message_at_caller(@_);
1354 die $self->_message_at_caller(@_);
1360 unless( $self->{Have_Plan} ) {
1361 local $Level = $Level + 1;
1362 $self->croak("You tried to run a test without a plan");
1369 =head2 Test Status and Info
1373 =item B<current_test>
1375 my $curr_test = $Test->current_test;
1376 $Test->current_test($num);
1378 Gets/sets the current test number we're on. You usually shouldn't
1381 If set forward, the details of the missing tests are filled in as 'unknown'.
1382 if set backward, the details of the intervening tests are deleted. You
1383 can erase history if you really want to.
1388 my($self, $num) = @_;
1390 lock($self->{Curr_Test});
1391 if( defined $num ) {
1392 unless( $self->{Have_Plan} ) {
1393 $self->croak("Can't change the current test number without a plan!");
1396 $self->{Curr_Test} = $num;
1398 # If the test counter is being pushed forward fill in the details.
1399 my $test_results = $self->{Test_Results};
1400 if( $num > @$test_results ) {
1401 my $start = @$test_results ? @$test_results : 0;
1402 for ($start..$num-1) {
1403 $test_results->[$_] = &share({
1406 reason => 'incrementing test number',
1412 # If backward, wipe history. Its their funeral.
1413 elsif( $num < @$test_results ) {
1414 $#{$test_results} = $num - 1;
1417 return $self->{Curr_Test};
1423 my @tests = $Test->summary;
1425 A simple summary of the tests so far. True for pass, false for fail.
1426 This is a logical pass/fail, so todos are passes.
1428 Of course, test #1 is $tests[0], etc...
1435 return map { $_->{'ok'} } @{ $self->{Test_Results} };
1440 my @tests = $Test->details;
1442 Like summary(), but with a lot more detail.
1444 $tests[$test_num - 1] =
1445 { 'ok' => is the test considered a pass?
1446 actual_ok => did it literally say 'ok'?
1447 name => name of the test (if any)
1448 type => type of test (if any, see below).
1449 reason => reason for the above (if any)
1452 'ok' is true if Test::Harness will consider the test to be a pass.
1454 'actual_ok' is a reflection of whether or not the test literally
1455 printed 'ok' or 'not ok'. This is for examining the result of 'todo'
1458 'name' is the name of the test.
1460 'type' indicates if it was a special test. Normal tests have a type
1461 of ''. Type can be one of the following:
1465 todo_skip see todo_skip()
1468 Sometimes the Test::Builder test counter is incremented without it
1469 printing any test output, for example, when current_test() is changed.
1470 In these cases, Test::Builder doesn't know the result of the test, so
1471 it's type is 'unkown'. These details for these tests are filled in.
1472 They are considered ok, but the name and actual_ok is left undef.
1474 For example "not ok 23 - hole count # TODO insufficient donuts" would
1475 result in this structure:
1477 $tests[22] = # 23 - 1, since arrays start from 0.
1478 { ok => 1, # logically, the test passed since it's todo
1479 actual_ok => 0, # in absolute terms, it failed
1480 name => 'hole count',
1482 reason => 'insufficient donuts'
1489 return @{ $self->{Test_Results} };
1494 my $todo_reason = $Test->todo;
1495 my $todo_reason = $Test->todo($pack);
1497 todo() looks for a $TODO variable in your tests. If set, all tests
1498 will be considered 'todo' (see Test::More and Test::Harness for
1499 details). Returns the reason (ie. the value of $TODO) if running as
1500 todo tests, false otherwise.
1502 todo() is about finding the right package to look for $TODO in. It
1503 uses the exported_to() package to find it. If that's not set, it's
1504 pretty good at guessing the right package to look at based on $Level.
1506 Sometimes there is some confusion about where todo() should be looking
1507 for the $TODO variable. If you want to be sure, tell it explicitly
1513 my($self, $pack) = @_;
1515 $pack = $pack || $self->exported_to || $self->caller($Level);
1516 return 0 unless $pack;
1519 return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
1525 my $package = $Test->caller;
1526 my($pack, $file, $line) = $Test->caller;
1527 my($pack, $file, $line) = $Test->caller($height);
1529 Like the normal caller(), except it reports according to your level().
1534 my($self, $height) = @_;
1537 my @caller = CORE::caller($self->level + $height + 1);
1538 return wantarray ? @caller : $caller[0];
1549 =item B<_sanity_check>
1551 $self->_sanity_check();
1553 Runs a bunch of end of test sanity checks to make sure reality came
1554 through ok. If anything is wrong it will die with a fairly friendly
1563 $self->_whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!');
1564 $self->_whoa(!$self->{Have_Plan} and $self->{Curr_Test},
1565 'Somehow your tests ran without a plan!');
1566 $self->_whoa($self->{Curr_Test} != @{ $self->{Test_Results} },
1567 'Somehow you got a different number of results than tests ran!');
1572 $self->_whoa($check, $description);
1574 A sanity check, similar to assert(). If the $check is true, something
1575 has gone horribly wrong. It will die with the given $description and
1576 a note to contact the author.
1581 my($self, $check, $desc) = @_;
1583 local $Level = $Level + 1;
1584 $self->croak(<<"WHOA");
1586 This should never happen! Please contact the author immediately!
1593 _my_exit($exit_num);
1595 Perl seems to have some trouble with exiting inside an END block. 5.005_03
1596 and 5.6.1 both seem to do odd things. Instead, this function edits $?
1597 directly. It should ONLY be called from inside an END block. It
1598 doesn't actually exit, that's your job.
1615 $SIG{__DIE__} = sub {
1616 # We don't want to muck with death in an eval, but $^S isn't
1617 # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
1618 # with it. Instead, we use caller. This also means it runs under
1621 for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) {
1622 $in_eval = 1 if $sub =~ /^\(eval\)/;
1624 $Test->{Test_Died} = 1 unless $in_eval;
1630 $self->_sanity_check();
1632 # Don't bother with an ending if this is a forked copy. Only the parent
1633 # should do the ending.
1634 # Exit if plan() was never called. This is so "require Test::Simple"
1636 # Don't do an ending if we bailed out.
1637 if( ($self->{Original_Pid} != $$) or
1638 (!$self->{Have_Plan} && !$self->{Test_Died}) or
1646 # Figure out if we passed or failed and print helpful messages.
1647 my $test_results = $self->{Test_Results};
1648 if( @$test_results ) {
1649 # The plan? We have no plan.
1650 if( $self->{No_Plan} ) {
1651 $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
1652 $self->{Expected_Tests} = $self->{Curr_Test};
1655 # Auto-extended arrays and elements which aren't explicitly
1656 # filled in with a shared reference will puke under 5.8.0
1657 # ithreads. So we have to fill them in by hand. :(
1658 my $empty_result = &share({});
1659 for my $idx ( 0..$self->{Expected_Tests}-1 ) {
1660 $test_results->[$idx] = $empty_result
1661 unless defined $test_results->[$idx];
1664 my $num_failed = grep !$_->{'ok'},
1665 @{$test_results}[0..$self->{Curr_Test}-1];
1667 my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
1669 if( $num_extra < 0 ) {
1670 my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1671 $self->diag(<<"FAIL");
1672 Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}.
1675 elsif( $num_extra > 0 ) {
1676 my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1677 $self->diag(<<"FAIL");
1678 Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra.
1682 if ( $num_failed ) {
1683 my $num_tests = $self->{Curr_Test};
1684 my $s = $num_failed == 1 ? '' : 's';
1686 my $qualifier = $num_extra == 0 ? '' : ' run';
1688 $self->diag(<<"FAIL");
1689 Looks like you failed $num_failed test$s of $num_tests$qualifier.
1693 if( $self->{Test_Died} ) {
1694 $self->diag(<<"FAIL");
1695 Looks like your test died just after $self->{Curr_Test}.
1698 _my_exit( 255 ) && return;
1703 $exit_code = $num_failed <= 254 ? $num_failed : 254;
1705 elsif( $num_extra != 0 ) {
1712 _my_exit( $exit_code ) && return;
1714 elsif ( $self->{Skip_All} ) {
1715 _my_exit( 0 ) && return;
1717 elsif ( $self->{Test_Died} ) {
1718 $self->diag(<<'FAIL');
1719 Looks like your test died before it could output anything.
1721 _my_exit( 255 ) && return;
1724 $self->diag("No tests run!\n");
1725 _my_exit( 255 ) && return;
1730 $Test->_ending if defined $Test and !$Test->no_ending;
1735 If all your tests passed, Test::Builder will exit with zero (which is
1736 normal). If anything failed it will exit with how many failed. If
1737 you run less (or more) tests than you planned, the missing (or extras)
1738 will be considered failures. If no tests were ever run Test::Builder
1739 will throw a warning and exit with 255. If the test died, even after
1740 having successfully completed all its tests, it will still be
1741 considered a failure and will exit with 255.
1743 So the exit codes are...
1745 0 all tests successful
1746 255 test died or all passed but wrong # of tests run
1747 any other number how many failed (including missing or extras)
1749 If you fail more than 254 tests, it will be reported as 254.
1754 In perl 5.8.1 and later, Test::Builder is thread-safe. The test
1755 number is shared amongst all threads. This means if one thread sets
1756 the test number using current_test() they will all be effected.
1758 While versions earlier than 5.8.1 had threads they contain too many
1761 Test::Builder is only thread-aware if threads.pm is loaded I<before>
1766 CPAN can provide the best examples. Test::Simple, Test::More,
1767 Test::Exception and Test::Differences all use Test::Builder.
1771 Test::Simple, Test::More, Test::Harness
1775 Original code by chromatic, maintained by Michael G Schwern
1776 E<lt>schwern@pobox.comE<gt>
1780 Copyright 2002, 2004 by chromatic E<lt>chromatic@wgz.orgE<gt> and
1781 Michael G Schwern E<lt>schwern@pobox.comE<gt>.
1783 This program is free software; you can redistribute it and/or
1784 modify it under the same terms as Perl itself.
1786 See F<http://www.perl.com/perl/misc/Artistic.html>