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.
18 # Load threads::shared when threads are turned on.
19 # 5.8.0's threads are so busted we no longer support them.
20 if ( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
21 require threads::shared;
23 # Hack around YET ANOTHER threads::shared bug. It would
24 # occassionally forget the contents of the variable when sharing it.
25 # So we first copy the data, then share, then put our copy back.
26 *share = sub (\[$@%]) {
30 if ( $type eq 'HASH' ) {
33 elsif ( $type eq 'ARRAY' ) {
36 elsif ( $type eq 'SCALAR' ) {
40 die( "Unknown type: " . $type );
43 $_[0] = &threads::shared::share( $_[0] );
45 if ( $type eq 'HASH' ) {
48 elsif ( $type eq 'ARRAY' ) {
51 elsif ( $type eq 'SCALAR' ) {
55 die( "Unknown type: " . $type );
62 # 5.8.0's threads::shared is busted when threads are off
63 # and earlier Perls just don't have that module at all.
65 *share = sub { return $_[0] };
72 Test::Builder - Backend for building test libraries
76 package My::Test::Module;
82 my $Test = Test::Builder->new;
83 $Test->output('my_logfile');
89 $Test->exported_to($pack);
92 $self->export_to_level(1, $self, 'ok');
96 my($test, $name) = @_;
98 $Test->ok($test, $name);
104 Test::Simple and Test::More have proven to be popular testing modules,
105 but they're not always flexible enough. Test::Builder provides the a
106 building block upon which to write your own test libraries I<which can
115 my $Test = Test::Builder->new;
117 Returns a Test::Builder object representing the current state of the
120 Since you only run one test per program C<new> always returns the same
121 Test::Builder object. No matter how many times you call new(), you're
122 getting the same object. This is called a singleton. This is done so that
123 multiple modules share such global information as the test counter and
124 where test output is going.
126 If you want a completely new Test::Builder object different from the
127 singleton, use C<create>.
131 my $Test = Test::Builder->new;
135 $Test ||= $class->create;
141 my $Test = Test::Builder->create;
143 Ok, so there can be more than one Test::Builder object and this is how
144 you get it. You might use this instead of C<new()> if you're testing
145 a Test::Builder based module, but otherwise you probably want C<new>.
147 B<NOTE>: the implementation is not complete. C<level>, for example, is
148 still shared amongst B<all> Test::Builder objects, even ones created using
149 this method. Also, the method name may change in the future.
156 my $self = bless {}, $class;
166 Reinitializes the Test::Builder singleton to its original state.
167 Mostly useful for tests run in persistent environments where the same
168 test might be run multiple times in the same process.
177 # We leave this a global because it has to be localized and localizing
178 # hash keys is just asking for pain. Also, it was documented.
181 $self->{Test_Died} = 0;
182 $self->{Have_Plan} = 0;
183 $self->{No_Plan} = 0;
184 $self->{Original_Pid} = $$;
186 share( $self->{Curr_Test} );
187 $self->{Curr_Test} = 0;
188 $self->{Test_Results} = &share( [] );
190 $self->{Exported_To} = undef;
191 $self->{Expected_Tests} = 0;
193 $self->{Skip_All} = 0;
195 $self->{Use_Nums} = 1;
197 $self->{No_Header} = 0;
198 $self->{No_Ending} = 0;
200 $self->_dup_stdhandles unless $^C;
207 =head2 Setting up tests
209 These methods are for setting up tests and declaring how many there
210 are. You usually only want to call one of these methods.
216 my $pack = $Test->exported_to;
217 $Test->exported_to($pack);
219 Tells Test::Builder what package you exported your functions to.
220 This is important for getting TODO tests right.
225 my ( $self, $pack ) = @_;
227 if ( defined $pack ) {
228 $self->{Exported_To} = $pack;
230 return $self->{Exported_To};
235 $Test->plan('no_plan');
236 $Test->plan( skip_all => $reason );
237 $Test->plan( tests => $num_tests );
239 A convenient way to set up your tests. Call this and Test::Builder
240 will print the appropriate headers and take the appropriate actions.
242 If you call plan(), don't call any of the other methods below.
247 my ( $self, $cmd, $arg ) = @_;
251 local $Level = $Level + 1;
253 if ( $self->{Have_Plan} ) {
254 $self->croak("You tried to plan twice");
257 if ( $cmd eq 'no_plan' ) {
260 elsif ( $cmd eq 'skip_all' ) {
261 return $self->skip_all($arg);
263 elsif ( $cmd eq 'tests' ) {
265 local $Level = $Level + 1;
266 return $self->expected_tests($arg);
268 elsif ( !defined $arg ) {
269 $self->croak("Got an undefined number of tests");
272 $self->croak("You said to run 0 tests");
276 my @args = grep {defined} ( $cmd, $arg );
277 $self->croak("plan() doesn't understand @args");
283 =item B<expected_tests>
285 my $max = $Test->expected_tests;
286 $Test->expected_tests($max);
288 Gets/sets the # of tests we expect this test to run and prints out
289 the appropriate headers.
299 "Number of tests must be a positive integer. You gave it '$max'")
300 unless $max =~ /^\+?\d+$/ and $max > 0;
302 $self->{Expected_Tests} = $max;
303 $self->{Have_Plan} = 1;
305 $self->_print("1..$max\n") unless $self->no_header;
307 return $self->{Expected_Tests};
314 Declares that this test will run an indeterminate # of tests.
321 $self->{No_Plan} = 1;
322 $self->{Have_Plan} = 1;
327 $plan = $Test->has_plan
329 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).
336 return ( $self->{Expected_Tests} ) if $self->{Expected_Tests};
337 return ('no_plan') if $self->{No_Plan};
344 $Test->skip_all($reason);
346 Skips all the tests, using the given $reason. Exits immediately with 0.
351 my ( $self, $reason ) = @_;
354 $out .= " # Skip $reason" if $reason;
357 $self->{Skip_All} = 1;
359 $self->_print($out) unless $self->no_header;
367 These actually run the tests, analogous to the functions in Test::More.
369 They all return true if the test passed, false if the test failed.
371 $name is always optional.
377 $Test->ok($test, $name);
379 Your basic test. Pass if $test is true, fail if $test is false. Just
380 like Test::Simple's ok().
385 my ( $self, $test, $name ) = @_;
387 # $test might contain an object which we don't want to accidentally
388 # store, so we turn it into a boolean.
389 $test = $test ? 1 : 0;
393 lock $self->{Curr_Test};
394 $self->{Curr_Test}++;
396 # In case $name is a string overloaded object, force it to stringify.
397 $self->_unoverload_str( \$name );
399 $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
400 You named your test '$name'. You shouldn't use numbers for your test names.
404 my ( $pack, $file, $line ) = $self->caller;
406 my $todo = $self->todo($pack);
407 $self->_unoverload_str( \$todo );
410 my $result = &share( {} );
414 @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
417 @$result{ 'ok', 'actual_ok' } = ( 1, $test );
421 $out .= " $self->{Curr_Test}" if $self->use_numbers;
423 if ( defined $name ) {
424 $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
426 $result->{name} = $name;
429 $result->{name} = '';
433 $out .= " # TODO $todo";
434 $result->{reason} = $todo;
435 $result->{type} = 'todo';
438 $result->{reason} = '';
439 $result->{type} = '';
442 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
448 my $msg = $todo ? "Failed (TODO)" : "Failed";
449 $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
451 if ( defined $name ) {
452 $self->diag(qq[ $msg test '$name'\n]);
453 $self->diag(qq[ at $file line $line.\n]);
456 $self->diag(qq[ $msg test at $file line $line.\n]);
460 return $test ? 1 : 0;
467 $self->_try( sub { require overload } ) || return;
469 foreach my $thing (@_) {
470 if ( $self->_is_object($$thing) ) {
471 if ( my $string_meth = overload::Method( $$thing, $type ) ) {
472 $$thing = $$thing->$string_meth();
479 my ( $self, $thing ) = @_;
481 return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } )
486 sub _unoverload_str {
489 $self->_unoverload( q[""], @_ );
492 sub _unoverload_num {
495 $self->_unoverload( '0+', @_ );
498 next unless $self->_is_dualvar($$val);
503 # This is a hack to detect a dualvar such as $!
505 my ( $self, $val ) = @_;
508 my $numval = $val + 0;
509 return 1 if $numval != 0 and $numval ne $val;
514 $Test->is_eq($got, $expected, $name);
516 Like Test::More's is(). Checks if $got eq $expected. This is the
521 $Test->is_num($got, $expected, $name);
523 Like Test::More's is(). Checks if $got == $expected. This is the
529 my ( $self, $got, $expect, $name ) = @_;
530 local $Level = $Level + 1;
532 $self->_unoverload_str( \$got, \$expect );
534 if ( !defined $got || !defined $expect ) {
536 # undef only matches undef and nothing else
537 my $test = !defined $got && !defined $expect;
539 $self->ok( $test, $name );
540 $self->_is_diag( $got, 'eq', $expect ) unless $test;
544 return $self->cmp_ok( $got, 'eq', $expect, $name );
548 my ( $self, $got, $expect, $name ) = @_;
549 local $Level = $Level + 1;
551 $self->_unoverload_num( \$got, \$expect );
553 if ( !defined $got || !defined $expect ) {
555 # undef only matches undef and nothing else
556 my $test = !defined $got && !defined $expect;
558 $self->ok( $test, $name );
559 $self->_is_diag( $got, '==', $expect ) unless $test;
563 return $self->cmp_ok( $got, '==', $expect, $name );
567 my ( $self, $got, $type, $expect ) = @_;
569 foreach my $val ( \$got, \$expect ) {
570 if ( defined $$val ) {
571 if ( $type eq 'eq' ) {
573 # quote and force string context
578 # force numeric context
579 $self->_unoverload_num($val);
587 return $self->diag( sprintf <<DIAGNOSTIC, $got, $expect );
596 $Test->isnt_eq($got, $dont_expect, $name);
598 Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
603 $Test->isnt_num($got, $dont_expect, $name);
605 Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
611 my ( $self, $got, $dont_expect, $name ) = @_;
612 local $Level = $Level + 1;
614 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 ) {
633 # undef only matches undef and nothing else
634 my $test = defined $got || defined $dont_expect;
636 $self->ok( $test, $name );
637 $self->_cmp_diag( $got, '!=', $dont_expect ) unless $test;
641 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->cmp_ok($this, $type, $that, $name);
681 Works just like Test::More's cmp_ok().
683 $Test->cmp_ok($big_num, '!=', $other_big_num);
688 = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
691 my ( $self, $got, $type, $expect, $name ) = @_;
693 # Treat overloaded objects as numbers if we're asked to do a
694 # numeric comparison.
696 = $numeric_cmps{$type}
700 $self->$unoverload( \$got, \$expect );
704 local ( $@, $!, $SIG{__DIE__} ); # isolate eval
706 my $code = $self->_caller_context;
708 # Yes, it has to look like this or 5.4.5 won't see the #line directive.
709 # Don't ask me, man, I just work here.
711 $code" . "\$got $type \$expect;";
714 local $Level = $Level + 1;
715 my $ok = $self->ok( $test, $name );
718 if ( $type =~ /^(eq|==)$/ ) {
719 $self->_is_diag( $got, $type, $expect );
722 $self->_cmp_diag( $got, $type, $expect );
729 my ( $self, $got, $type, $expect ) = @_;
731 $got = defined $got ? "'$got'" : 'undef';
732 $expect = defined $expect ? "'$expect'" : 'undef';
733 return $self->diag( sprintf <<DIAGNOSTIC, $got, $type, $expect );
740 sub _caller_context {
743 my ( $pack, $file, $line ) = $self->caller(1);
746 $code .= "#line $line $file\n" if defined $file and defined $line;
754 =head2 Other Testing Methods
756 These are methods which are used in the course of writing a test but are not themselves tests.
762 $Test->BAIL_OUT($reason);
764 Indicates to the Test::Harness that things are going so badly all
765 testing should terminate. This includes running any additional test
768 It will exit with 255.
773 my ( $self, $reason ) = @_;
775 $self->{Bailed_Out} = 1;
776 $self->_print("Bail out! $reason");
781 BAIL_OUT() used to be BAILOUT()
785 *BAILOUT = \&BAIL_OUT;
792 Skips the current test, reporting $why.
797 my ( $self, $why ) = @_;
799 $self->_unoverload_str( \$why );
803 lock( $self->{Curr_Test} );
804 $self->{Curr_Test}++;
806 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
816 $out .= " $self->{Curr_Test}" if $self->use_numbers;
818 $out .= " $why" if length $why;
829 $Test->todo_skip($why);
831 Like skip(), only it will declare the test as failing and TODO. Similar
834 print "not ok $tnum # TODO $why\n";
839 my ( $self, $why ) = @_;
844 lock( $self->{Curr_Test} );
845 $self->{Curr_Test}++;
847 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
857 $out .= " $self->{Curr_Test}" if $self->use_numbers;
858 $out .= " # TODO & SKIP $why\n";
865 =begin _unimplemented
870 $Test->skip_rest($reason);
872 Like skip(), only it skips all the rest of the tests you plan to run
873 and terminates the test.
875 If you're running under no_plan, it skips once and terminates the
883 =head2 Test building utility methods
885 These methods are useful when writing your own test methods.
891 $Test->maybe_regex(qr/$regex/);
892 $Test->maybe_regex('/$regex/');
894 Convenience method for building testing functions that take regular
895 expressions as arguments, but need to work before perl 5.005.
897 Takes a quoted regular expression produced by qr//, or a string
898 representing a regular expression.
900 Returns a Perl value which may be used instead of the corresponding
901 regular expression, or undef if it's argument is not recognised.
903 For example, a version of like(), sans the useful diagnostic messages,
907 my ($self, $this, $regex, $name) = @_;
908 my $usable_regex = $self->maybe_regex($regex);
909 die "expecting regex, found '$regex'\n"
910 unless $usable_regex;
911 $self->ok($this =~ m/$usable_regex/, $name);
917 my ( $self, $regex ) = @_;
918 my $usable_regex = undef;
920 return $usable_regex unless defined $regex;
925 if ( ref $regex eq 'Regexp' ) {
926 $usable_regex = $regex;
929 # Check for '/foo/' or 'm,foo,'
930 elsif (( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx
931 or ( undef, $re, $opts )
932 = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx )
934 $usable_regex = length $opts ? "(?$opts)$re" : $re;
937 return $usable_regex;
941 my ( $self, $this, $regex, $cmp, $name ) = @_;
944 my $usable_regex = $self->maybe_regex($regex);
945 unless ( defined $usable_regex ) {
946 $ok = $self->ok( 0, $name );
947 $self->diag(" '$regex' doesn't look much like a regex to me.");
953 my $code = $self->_caller_context;
955 local ( $@, $!, $SIG{__DIE__} ); # isolate eval
957 # Yes, it has to look like this or 5.4.5 won't see the #line directive.
958 # Don't ask me, man, I just work here.
960 $code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
962 $test = !$test if $cmp eq '!~';
964 local $Level = $Level + 1;
965 $ok = $self->ok( $test, $name );
969 $this = defined $this ? "'$this'" : 'undef';
970 my $match = $cmp eq '=~' ? "doesn't match" : "matches";
971 $self->diag( sprintf <<DIAGNOSTIC, $this, $match, $regex );
981 # I'm not ready to publish this. It doesn't deal with array return
982 # values from the code or context.
988 my $return_from_code = $Test->try(sub { code });
989 my($return_from_code, $error) = $Test->try(sub { code });
991 Works like eval BLOCK except it ensures it has no effect on the rest of the test (ie. $@ is not set) nor is effected by outside interference (ie. $SIG{__DIE__}) and works around some quirks in older Perls.
993 $error is what would normally be in $@.
995 It is suggested you use this in place of eval BLOCK.
1000 my ( $self, $code ) = @_;
1002 local $!; # eval can mess up $!
1003 local $@; # don't set $@ in the test
1004 local $SIG{__DIE__}; # don't trip an outside DIE handler.
1005 my $return = eval { $code->() };
1007 return wantarray ? ( $return, $@ ) : $return;
1015 my $is_fh = $Test->is_fh($thing);
1017 Determines if the given $thing can be used as a filehandle.
1023 my $maybe_fh = shift;
1024 return 0 unless defined $maybe_fh;
1026 return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
1027 return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
1029 return eval { $maybe_fh->isa("IO::Handle") } ||
1031 # 5.5.4's tied() and can() doesn't like getting undef
1032 eval { ( tied($maybe_fh) || '' )->can('TIEHANDLE') };
1045 $Test->level($how_high);
1047 How far up the call stack should $Test look when reporting where the
1052 Setting L<$Test::Builder::Level> overrides. This is typically useful
1058 local $Test::Builder::Level = $Test::Builder::Level + 1;
1062 To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant.
1067 my ( $self, $level ) = @_;
1069 if ( defined $level ) {
1075 =item B<use_numbers>
1077 $Test->use_numbers($on_or_off);
1079 Whether or not the test should output numbers. That is, this if true:
1091 Most useful when you can't depend on the test output order, such as
1092 when threads or forking is involved.
1099 my ( $self, $use_nums ) = @_;
1101 if ( defined $use_nums ) {
1102 $self->{Use_Nums} = $use_nums;
1104 return $self->{Use_Nums};
1109 $Test->no_diag($no_diag);
1111 If set true no diagnostics will be printed. This includes calls to
1116 $Test->no_ending($no_ending);
1118 Normally, Test::Builder does some extra diagnostics when the test
1119 ends. It also changes the exit code as described below.
1121 If this is true, none of that will be done.
1125 $Test->no_header($no_header);
1127 If set to true, no "1..N" header will be printed.
1131 foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
1132 my $method = lc $attribute;
1135 my ( $self, $no ) = @_;
1137 if ( defined $no ) {
1138 $self->{$attribute} = $no;
1140 return $self->{$attribute};
1144 *{ __PACKAGE__ . '::' . $method } = $code;
1151 Controlling where the test output goes.
1153 It's ok for your test to change where STDOUT and STDERR point to,
1154 Test::Builder's default output settings will not be affected.
1162 Prints out the given @msgs. Like C<print>, arguments are simply
1165 Normally, it uses the failure_output() handle, but if this is for a
1166 TODO test, the todo_output() handle is used.
1168 Output will be indented and marked with a # so as not to interfere
1169 with test output. A newline will be put on the end if there isn't one
1172 We encourage using this rather than calling print directly.
1174 Returns false. Why? Because diag() is often used in conjunction with
1175 a failing test (C<ok() || diag()>) it "passes through" the failure.
1177 return ok(...) || diag(...);
1180 Mark Fowler <mark@twoshortplanks.com>
1185 my ( $self, @msgs ) = @_;
1187 return if $self->no_diag;
1188 return unless @msgs;
1190 # Prevent printing headers when compiling (i.e. -c)
1193 # Smash args together like print does.
1194 # Convert undef to 'undef' so its readable.
1195 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1197 # Escape each line with a #.
1200 # Stick a newline on the end if it needs it.
1201 $msg .= "\n" unless $msg =~ /\n\Z/;
1203 local $Level = $Level + 1;
1204 $self->_print_diag($msg);
1213 $Test->_print(@msgs);
1215 Prints to the output() filehandle.
1222 my ( $self, @msgs ) = @_;
1224 # Prevent printing headers when only compiling. Mostly for when
1225 # tests are deparsed with B::Deparse
1228 my $msg = join '', @msgs;
1230 local ( $\, $", $, ) = ( undef, ' ', '' );
1231 my $fh = $self->output;
1233 # Escape each line after the first with a # so we don't
1234 # confuse Test::Harness.
1235 $msg =~ s/\n(.)/\n# $1/sg;
1237 # Stick a newline on the end if it needs it.
1238 $msg .= "\n" unless $msg =~ /\n\Z/;
1245 =item B<_print_diag>
1247 $Test->_print_diag(@msg);
1249 Like _print, but prints to the current diagnostic filehandle.
1258 local ( $\, $", $, ) = ( undef, ' ', '' );
1259 my $fh = $self->todo ? $self->todo_output : $self->failure_output;
1266 $Test->output($file);
1268 Where normal "ok/not ok" test output should go.
1272 =item B<failure_output>
1274 $Test->failure_output($fh);
1275 $Test->failure_output($file);
1277 Where diagnostic output on test failures and diag() should go.
1281 =item B<todo_output>
1283 $Test->todo_output($fh);
1284 $Test->todo_output($file);
1286 Where diagnostics about todo test failures and diag() should go.
1293 my ( $self, $fh ) = @_;
1295 if ( defined $fh ) {
1296 $self->{Out_FH} = $self->_new_fh($fh);
1298 return $self->{Out_FH};
1301 sub failure_output {
1302 my ( $self, $fh ) = @_;
1304 if ( defined $fh ) {
1305 $self->{Fail_FH} = $self->_new_fh($fh);
1307 return $self->{Fail_FH};
1311 my ( $self, $fh ) = @_;
1313 if ( defined $fh ) {
1314 $self->{Todo_FH} = $self->_new_fh($fh);
1316 return $self->{Todo_FH};
1321 my ($file_or_fh) = shift;
1324 if ( $self->is_fh($file_or_fh) ) {
1328 $fh = do { local *FH };
1329 open $fh, ">$file_or_fh"
1330 or $self->croak("Can't open test output log $file_or_fh: $!");
1339 my $old_fh = select $fh;
1344 sub _dup_stdhandles {
1347 $self->_open_testhandles;
1349 # Set everything to unbuffered else plain prints to STDOUT will
1350 # come out in the wrong order from our own prints.
1351 _autoflush( \*TESTOUT );
1352 _autoflush( \*STDOUT );
1353 _autoflush( \*TESTERR );
1354 _autoflush( \*STDERR );
1356 $self->output( \*TESTOUT );
1357 $self->failure_output( \*TESTERR );
1358 $self->todo_output( \*TESTOUT );
1361 my $Opened_Testhandles = 0;
1363 sub _open_testhandles {
1364 return if $Opened_Testhandles;
1366 # We dup STDOUT and STDERR so people can change them in their
1367 # test suites while still getting normal test output.
1368 open( TESTOUT, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
1369 open( TESTERR, ">&STDERR" ) or die "Can't dup STDERR: $!";
1370 $Opened_Testhandles = 1;
1375 $tb->carp(@message);
1377 Warns with C<@message> but the message will appear to come from the
1378 point where the original test function was called (C<$tb->caller>).
1382 $tb->croak(@message);
1384 Dies with C<@message> but the message will appear to come from the
1385 point where the original test function was called (C<$tb->caller>).
1389 sub _message_at_caller {
1392 local $Level = $Level + 1;
1393 my ( $pack, $file, $line ) = $self->caller;
1394 return join( "", @_ ) . " at $file line $line.\n";
1399 warn $self->_message_at_caller(@_);
1404 die $self->_message_at_caller(@_);
1410 unless ( $self->{Have_Plan} ) {
1411 local $Level = $Level + 2;
1412 $self->croak("You tried to run a test without a plan");
1419 =head2 Test Status and Info
1423 =item B<current_test>
1425 my $curr_test = $Test->current_test;
1426 $Test->current_test($num);
1428 Gets/sets the current test number we're on. You usually shouldn't
1431 If set forward, the details of the missing tests are filled in as 'unknown'.
1432 if set backward, the details of the intervening tests are deleted. You
1433 can erase history if you really want to.
1438 my ( $self, $num ) = @_;
1440 lock( $self->{Curr_Test} );
1441 if ( defined $num ) {
1442 unless ( $self->{Have_Plan} ) {
1444 "Can't change the current test number without a plan!");
1447 $self->{Curr_Test} = $num;
1449 # If the test counter is being pushed forward fill in the details.
1450 my $test_results = $self->{Test_Results};
1451 if ( $num > @$test_results ) {
1452 my $start = @$test_results ? @$test_results : 0;
1453 for ( $start .. $num - 1 ) {
1454 $test_results->[$_] = &share(
1457 reason => 'incrementing test number',
1465 # If backward, wipe history. Its their funeral.
1466 elsif ( $num < @$test_results ) {
1467 $#{$test_results} = $num - 1;
1470 return $self->{Curr_Test};
1475 my @tests = $Test->summary;
1477 A simple summary of the tests so far. True for pass, false for fail.
1478 This is a logical pass/fail, so todos are passes.
1480 Of course, test #1 is $tests[0], etc...
1487 return map { $_->{'ok'} } @{ $self->{Test_Results} };
1492 my @tests = $Test->details;
1494 Like summary(), but with a lot more detail.
1496 $tests[$test_num - 1] =
1497 { 'ok' => is the test considered a pass?
1498 actual_ok => did it literally say 'ok'?
1499 name => name of the test (if any)
1500 type => type of test (if any, see below).
1501 reason => reason for the above (if any)
1504 'ok' is true if Test::Harness will consider the test to be a pass.
1506 'actual_ok' is a reflection of whether or not the test literally
1507 printed 'ok' or 'not ok'. This is for examining the result of 'todo'
1510 'name' is the name of the test.
1512 'type' indicates if it was a special test. Normal tests have a type
1513 of ''. Type can be one of the following:
1517 todo_skip see todo_skip()
1520 Sometimes the Test::Builder test counter is incremented without it
1521 printing any test output, for example, when current_test() is changed.
1522 In these cases, Test::Builder doesn't know the result of the test, so
1523 it's type is 'unkown'. These details for these tests are filled in.
1524 They are considered ok, but the name and actual_ok is left undef.
1526 For example "not ok 23 - hole count # TODO insufficient donuts" would
1527 result in this structure:
1529 $tests[22] = # 23 - 1, since arrays start from 0.
1530 { ok => 1, # logically, the test passed since it's todo
1531 actual_ok => 0, # in absolute terms, it failed
1532 name => 'hole count',
1534 reason => 'insufficient donuts'
1541 return @{ $self->{Test_Results} };
1546 my $todo_reason = $Test->todo;
1547 my $todo_reason = $Test->todo($pack);
1549 todo() looks for a $TODO variable in your tests. If set, all tests
1550 will be considered 'todo' (see Test::More and Test::Harness for
1551 details). Returns the reason (ie. the value of $TODO) if running as
1552 todo tests, false otherwise.
1554 todo() is about finding the right package to look for $TODO in. It
1555 uses the exported_to() package to find it. If that's not set, it's
1556 pretty good at guessing the right package to look at based on $Level.
1558 Sometimes there is some confusion about where todo() should be looking
1559 for the $TODO variable. If you want to be sure, tell it explicitly
1565 my ( $self, $pack ) = @_;
1567 $pack = $pack || $self->exported_to || $self->caller($Level);
1568 return 0 unless $pack;
1571 return defined ${ $pack . '::TODO' }
1572 ? ${ $pack . '::TODO' }
1578 my $package = $Test->caller;
1579 my($pack, $file, $line) = $Test->caller;
1580 my($pack, $file, $line) = $Test->caller($height);
1582 Like the normal caller(), except it reports according to your level().
1587 my ( $self, $height ) = @_;
1590 my @caller = CORE::caller( $self->level + $height + 1 );
1591 return wantarray ? @caller : $caller[0];
1602 =item B<_sanity_check>
1604 $self->_sanity_check();
1606 Runs a bunch of end of test sanity checks to make sure reality came
1607 through ok. If anything is wrong it will die with a fairly friendly
1617 $self->{Curr_Test} < 0,
1618 'Says here you ran a negative number of tests!'
1621 !$self->{Have_Plan} and $self->{Curr_Test},
1622 'Somehow your tests ran without a plan!'
1625 $self->{Curr_Test} != @{ $self->{Test_Results} },
1626 'Somehow you got a different number of results than tests ran!'
1632 $self->_whoa($check, $description);
1634 A sanity check, similar to assert(). If the $check is true, something
1635 has gone horribly wrong. It will die with the given $description and
1636 a note to contact the author.
1641 my ( $self, $check, $desc ) = @_;
1643 local $Level = $Level + 1;
1644 $self->croak(<<"WHOA");
1646 This should never happen! Please contact the author immediately!
1653 _my_exit($exit_num);
1655 Perl seems to have some trouble with exiting inside an END block. 5.005_03
1656 and 5.6.1 both seem to do odd things. Instead, this function edits $?
1657 directly. It should ONLY be called from inside an END block. It
1658 doesn't actually exit, that's your job.
1674 $SIG{__DIE__} = sub {
1676 # We don't want to muck with death in an eval, but $^S isn't
1677 # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
1678 # with it. Instead, we use caller. This also means it runs under
1681 for ( my $stack = 1; my $sub = ( CORE::caller($stack) )[3]; $stack++ ) {
1682 $in_eval = 1 if $sub =~ /^\(eval\)/;
1684 $Test->{Test_Died} = 1 unless $in_eval;
1690 $self->_sanity_check();
1692 # Don't bother with an ending if this is a forked copy. Only the parent
1693 # should do the ending.
1694 # Exit if plan() was never called. This is so "require Test::Simple"
1696 # Don't do an ending if we bailed out.
1697 if ( ( $self->{Original_Pid} != $$ )
1698 or ( !$self->{Have_Plan} && !$self->{Test_Died} )
1699 or $self->{Bailed_Out} )
1705 # Figure out if we passed or failed and print helpful messages.
1706 my $test_results = $self->{Test_Results};
1707 if (@$test_results) {
1709 # The plan? We have no plan.
1710 if ( $self->{No_Plan} ) {
1711 $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
1712 $self->{Expected_Tests} = $self->{Curr_Test};
1715 # Auto-extended arrays and elements which aren't explicitly
1716 # filled in with a shared reference will puke under 5.8.0
1717 # ithreads. So we have to fill them in by hand. :(
1718 my $empty_result = &share( {} );
1719 for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
1720 $test_results->[$idx] = $empty_result
1721 unless defined $test_results->[$idx];
1724 my $num_failed = grep !$_->{'ok'},
1725 @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
1727 my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
1729 if ( $num_extra < 0 ) {
1730 my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1731 $self->diag(<<"FAIL");
1732 Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}.
1735 elsif ( $num_extra > 0 ) {
1736 my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1737 $self->diag(<<"FAIL");
1738 Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra.
1743 my $num_tests = $self->{Curr_Test};
1744 my $s = $num_failed == 1 ? '' : 's';
1746 my $qualifier = $num_extra == 0 ? '' : ' run';
1748 $self->diag(<<"FAIL");
1749 Looks like you failed $num_failed test$s of $num_tests$qualifier.
1753 if ( $self->{Test_Died} ) {
1754 $self->diag(<<"FAIL");
1755 Looks like your test died just after $self->{Curr_Test}.
1758 _my_exit(255) && return;
1763 $exit_code = $num_failed <= 254 ? $num_failed : 254;
1765 elsif ( $num_extra != 0 ) {
1772 _my_exit($exit_code) && return;
1774 elsif ( $self->{Skip_All} ) {
1775 _my_exit(0) && return;
1777 elsif ( $self->{Test_Died} ) {
1778 $self->diag(<<'FAIL');
1779 Looks like your test died before it could output anything.
1781 _my_exit(255) && return;
1784 $self->diag("No tests run!\n");
1785 _my_exit(255) && return;
1790 $Test->_ending if defined $Test and !$Test->no_ending;
1795 If all your tests passed, Test::Builder will exit with zero (which is
1796 normal). If anything failed it will exit with how many failed. If
1797 you run less (or more) tests than you planned, the missing (or extras)
1798 will be considered failures. If no tests were ever run Test::Builder
1799 will throw a warning and exit with 255. If the test died, even after
1800 having successfully completed all its tests, it will still be
1801 considered a failure and will exit with 255.
1803 So the exit codes are...
1805 0 all tests successful
1806 255 test died or all passed but wrong # of tests run
1807 any other number how many failed (including missing or extras)
1809 If you fail more than 254 tests, it will be reported as 254.
1814 In perl 5.8.1 and later, Test::Builder is thread-safe. The test
1815 number is shared amongst all threads. This means if one thread sets
1816 the test number using current_test() they will all be effected.
1818 While versions earlier than 5.8.1 had threads they contain too many
1821 Test::Builder is only thread-aware if threads.pm is loaded I<before>
1826 CPAN can provide the best examples. Test::Simple, Test::More,
1827 Test::Exception and Test::Differences all use Test::Builder.
1831 Test::Simple, Test::More, Test::Harness
1835 Original code by chromatic, maintained by Michael G Schwern
1836 E<lt>schwern@pobox.comE<gt>
1840 Copyright 2002, 2004 by chromatic E<lt>chromatic@wgz.orgE<gt> and
1841 Michael G Schwern E<lt>schwern@pobox.comE<gt>.
1843 This program is free software; you can redistribute it and/or
1844 modify it under the same terms as Perl itself.
1846 See F<http://www.perl.com/perl/misc/Artistic.html>