8 $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
12 require Test::Builder::IO::Scalar;
17 # Make Test::Builder thread-safe for ithreads.
20 # Load threads::shared when threads are turned on.
21 # 5.8.0's threads are so busted we no longer support them.
22 if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
23 require threads::shared;
25 # Hack around YET ANOTHER threads::shared bug. It would
26 # occassionally forget the contents of the variable when sharing it.
27 # So we first copy the data, then share, then put our copy back.
28 *share = sub (\[$@%]) {
32 if( $type eq 'HASH' ) {
35 elsif( $type eq 'ARRAY' ) {
38 elsif( $type eq 'SCALAR' ) {
42 die( "Unknown type: " . $type );
45 $_[0] = &threads::shared::share( $_[0] );
47 if( $type eq 'HASH' ) {
50 elsif( $type eq 'ARRAY' ) {
53 elsif( $type eq 'SCALAR' ) {
57 die( "Unknown type: " . $type );
63 # 5.8.0's threads::shared is busted when threads are off
64 # and earlier Perls just don't have that module at all.
66 *share = sub { return $_[0] };
73 Test::Builder - Backend for building test libraries
77 package My::Test::Module;
78 use base 'Test::Builder::Module';
80 my $CLASS = __PACKAGE__;
83 my($test, $name) = @_;
84 my $tb = $CLASS->builder;
86 $tb->ok($test, $name);
92 Test::Simple and Test::More have proven to be popular testing modules,
93 but they're not always flexible enough. Test::Builder provides the a
94 building block upon which to write your own test libraries I<which can
103 my $Test = Test::Builder->new;
105 Returns a Test::Builder object representing the current state of the
108 Since you only run one test per program C<new> always returns the same
109 Test::Builder object. No matter how many times you call C<new()>, you're
110 getting the same object. This is called a singleton. This is done so that
111 multiple modules share such global information as the test counter and
112 where test output is going.
114 If you want a completely new Test::Builder object different from the
115 singleton, use C<create>.
119 my $Test = Test::Builder->new;
123 $Test ||= $class->create;
129 my $Test = Test::Builder->create;
131 Ok, so there can be more than one Test::Builder object and this is how
132 you get it. You might use this instead of C<new()> if you're testing
133 a Test::Builder based module, but otherwise you probably want C<new>.
135 B<NOTE>: the implementation is not complete. C<level>, for example, is
136 still shared amongst B<all> Test::Builder objects, even ones created using
137 this method. Also, the method name may change in the future.
144 my $self = bless {}, $class;
154 Reinitializes the Test::Builder singleton to its original state.
155 Mostly useful for tests run in persistent environments where the same
156 test might be run multiple times in the same process.
162 sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
165 # We leave this a global because it has to be localized and localizing
166 # hash keys is just asking for pain. Also, it was documented.
169 $self->{Have_Plan} = 0;
170 $self->{No_Plan} = 0;
171 $self->{Have_Output_Plan} = 0;
173 $self->{Original_Pid} = $$;
175 share( $self->{Curr_Test} );
176 $self->{Curr_Test} = 0;
177 $self->{Test_Results} = &share( [] );
179 $self->{Exported_To} = undef;
180 $self->{Expected_Tests} = 0;
182 $self->{Skip_All} = 0;
184 $self->{Use_Nums} = 1;
186 $self->{No_Header} = 0;
187 $self->{No_Ending} = 0;
189 $self->{Todo} = undef;
190 $self->{Todo_Stack} = [];
191 $self->{Start_Todo} = 0;
192 $self->{Opened_Testhandles} = 0;
194 $self->_dup_stdhandles;
201 =head2 Setting up tests
203 These methods are for setting up tests and declaring how many there
204 are. You usually only want to call one of these methods.
210 $Test->plan('no_plan');
211 $Test->plan( skip_all => $reason );
212 $Test->plan( tests => $num_tests );
214 A convenient way to set up your tests. Call this and Test::Builder
215 will print the appropriate headers and take the appropriate actions.
217 If you call C<plan()>, don't call any of the other methods below.
222 no_plan => \&no_plan,
223 skip_all => \&skip_all,
224 tests => \&_plan_tests,
228 my( $self, $cmd, $arg ) = @_;
232 local $Level = $Level + 1;
234 $self->croak("You tried to plan twice") if $self->{Have_Plan};
236 if( my $method = $plan_cmds{$cmd} ) {
237 local $Level = $Level + 1;
238 $self->$method($arg);
241 my @args = grep { defined } ( $cmd, $arg );
242 $self->croak("plan() doesn't understand @args");
250 my($self, $arg) = @_;
253 local $Level = $Level + 1;
254 return $self->expected_tests($arg);
256 elsif( !defined $arg ) {
257 $self->croak("Got an undefined number of tests");
260 $self->croak("You said to run 0 tests");
267 =item B<expected_tests>
269 my $max = $Test->expected_tests;
270 $Test->expected_tests($max);
272 Gets/sets the number of tests we expect this test to run and prints out
273 the appropriate headers.
282 $self->croak("Number of tests must be a positive integer. You gave it '$max'")
283 unless $max =~ /^\+?\d+$/;
285 $self->{Expected_Tests} = $max;
286 $self->{Have_Plan} = 1;
288 $self->_output_plan($max) unless $self->no_header;
290 return $self->{Expected_Tests};
297 Declares that this test will run an indeterminate number of tests.
302 my($self, $arg) = @_;
304 $self->carp("no_plan takes no arguments") if $arg;
306 $self->{No_Plan} = 1;
307 $self->{Have_Plan} = 1;
315 =item B<_output_plan>
317 $tb->_output_plan($max);
318 $tb->_output_plan($max, $directive);
319 $tb->_output_plan($max, $directive => $reason);
321 Handles displaying the test plan.
323 If a C<$directive> and/or C<$reason> are given they will be output with the
324 plan. So here's what skipping all tests looks like:
326 $tb->_output_plan(0, "SKIP", "Because I said so");
328 It sets C<< $tb->{Have_Output_Plan} >> and will croak if the plan was already
336 my($self, $max, $directive, $reason) = @_;
338 $self->carp("The plan was already output") if $self->{Have_Output_Plan};
340 my $plan = "1..$max";
341 $plan .= " # $directive" if defined $directive;
342 $plan .= " $reason" if defined $reason;
344 $self->_print("$plan\n");
346 $self->{Have_Output_Plan} = 1;
351 =item B<done_testing>
353 $Test->done_testing();
354 $Test->done_testing($num_tests);
356 Declares that you are done testing, no more tests will be run after this point.
358 If a plan has not yet been output, it will do so.
360 $num_tests is the number of tests you planned to run. If a numbered
361 plan was already declared, and if this contradicts, a failing test
362 will be run to reflect the planning mistake. If C<no_plan> was declared,
365 If C<done_testing()> is called twice, the second call will issue a
368 If C<$num_tests> is omitted, the number of tests run will be used, like
371 C<done_testing()> is, in effect, used when you'd want to use C<no_plan>, but
372 safer. You'd use it like so:
375 $Test->done_testing();
377 Or to plan a variable number of tests:
379 for my $test (@tests) {
382 $Test->done_testing(@tests);
387 my($self, $num_tests) = @_;
389 # If done_testing() specified the number of tests, shut off no_plan.
390 if( defined $num_tests ) {
391 $self->{No_Plan} = 0;
394 $num_tests = $self->current_test;
397 if( $self->{Done_Testing} ) {
398 my($file, $line) = @{$self->{Done_Testing}}[1,2];
399 $self->ok(0, "done_testing() was already called at $file line $line");
403 $self->{Done_Testing} = [caller];
405 if( $self->expected_tests && $num_tests != $self->expected_tests ) {
406 $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
407 "but done_testing() expects $num_tests");
410 $self->{Expected_Tests} = $num_tests;
413 $self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
415 $self->{Have_Plan} = 1;
423 $plan = $Test->has_plan
425 Find out whether a plan has been defined. C<$plan> is either C<undef> (no plan
426 has been set), C<no_plan> (indeterminate # of tests) or an integer (the number
434 return( $self->{Expected_Tests} ) if $self->{Expected_Tests};
435 return('no_plan') if $self->{No_Plan};
442 $Test->skip_all($reason);
444 Skips all the tests, using the given C<$reason>. Exits immediately with 0.
449 my( $self, $reason ) = @_;
451 $self->{Skip_All} = 1;
453 $self->_output_plan(0, "SKIP", $reason) unless $self->no_header;
459 my $pack = $Test->exported_to;
460 $Test->exported_to($pack);
462 Tells Test::Builder what package you exported your functions to.
464 This method isn't terribly useful since modules which share the same
465 Test::Builder object might get exported to different packages and only
466 the last one will be honored.
471 my( $self, $pack ) = @_;
473 if( defined $pack ) {
474 $self->{Exported_To} = $pack;
476 return $self->{Exported_To};
483 These actually run the tests, analogous to the functions in Test::More.
485 They all return true if the test passed, false if the test failed.
487 C<$name> is always optional.
493 $Test->ok($test, $name);
495 Your basic test. Pass if C<$test> is true, fail if $test is false. Just
496 like Test::Simple's C<ok()>.
501 my( $self, $test, $name ) = @_;
503 # $test might contain an object which we don't want to accidentally
504 # store, so we turn it into a boolean.
505 $test = $test ? 1 : 0;
507 lock $self->{Curr_Test};
508 $self->{Curr_Test}++;
510 # In case $name is a string overloaded object, force it to stringify.
511 $self->_unoverload_str( \$name );
513 $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
514 You named your test '$name'. You shouldn't use numbers for your test names.
518 # Capture the value of $TODO for the rest of this ok() call
519 # so it can more easily be found by other routines.
520 my $todo = $self->todo();
521 my $in_todo = $self->in_todo;
522 local $self->{Todo} = $todo if $in_todo;
524 $self->_unoverload_str( \$todo );
527 my $result = &share( {} );
531 @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
534 @$result{ 'ok', 'actual_ok' } = ( 1, $test );
538 $out .= " $self->{Curr_Test}" if $self->use_numbers;
540 if( defined $name ) {
541 $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
543 $result->{name} = $name;
546 $result->{name} = '';
549 if( $self->in_todo ) {
550 $out .= " # TODO $todo";
551 $result->{reason} = $todo;
552 $result->{type} = 'todo';
555 $result->{reason} = '';
556 $result->{type} = '';
559 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
565 my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
566 $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
568 my( undef, $file, $line ) = $self->caller;
569 if( defined $name ) {
570 $self->diag(qq[ $msg test '$name'\n]);
571 $self->diag(qq[ at $file line $line.\n]);
574 $self->diag(qq[ $msg test at $file line $line.\n]);
578 return $test ? 1 : 0;
585 $self->_try(sub { require overload; }, die_on_fail => 1);
587 foreach my $thing (@_) {
588 if( $self->_is_object($$thing) ) {
589 if( my $string_meth = overload::Method( $$thing, $type ) ) {
590 $$thing = $$thing->$string_meth();
599 my( $self, $thing ) = @_;
601 return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
604 sub _unoverload_str {
607 return $self->_unoverload( q[""], @_ );
610 sub _unoverload_num {
613 $self->_unoverload( '0+', @_ );
616 next unless $self->_is_dualvar($$val);
623 # This is a hack to detect a dualvar such as $!
625 my( $self, $val ) = @_;
627 # Objects are not dualvars.
628 return 0 if ref $val;
630 no warnings 'numeric';
631 my $numval = $val + 0;
632 return $numval != 0 and $numval ne $val ? 1 : 0;
637 $Test->is_eq($got, $expected, $name);
639 Like Test::More's C<is()>. Checks if C<$got eq $expected>. This is the
644 $Test->is_num($got, $expected, $name);
646 Like Test::More's C<is()>. Checks if C<$got == $expected>. This is the
652 my( $self, $got, $expect, $name ) = @_;
653 local $Level = $Level + 1;
655 $self->_unoverload_str( \$got, \$expect );
657 if( !defined $got || !defined $expect ) {
658 # undef only matches undef and nothing else
659 my $test = !defined $got && !defined $expect;
661 $self->ok( $test, $name );
662 $self->_is_diag( $got, 'eq', $expect ) unless $test;
666 return $self->cmp_ok( $got, 'eq', $expect, $name );
670 my( $self, $got, $expect, $name ) = @_;
671 local $Level = $Level + 1;
673 $self->_unoverload_num( \$got, \$expect );
675 if( !defined $got || !defined $expect ) {
676 # undef only matches undef and nothing else
677 my $test = !defined $got && !defined $expect;
679 $self->ok( $test, $name );
680 $self->_is_diag( $got, '==', $expect ) unless $test;
684 return $self->cmp_ok( $got, '==', $expect, $name );
688 my( $self, $type, $val ) = @_;
690 if( defined $$val ) {
691 if( $type eq 'eq' or $type eq 'ne' ) {
692 # quote and force string context
696 # force numeric context
697 $self->_unoverload_num($val);
708 my( $self, $got, $type, $expect ) = @_;
710 $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
712 local $Level = $Level + 1;
713 return $self->diag(<<"DIAGNOSTIC");
721 my( $self, $got, $type ) = @_;
723 $self->_diag_fmt( $type, \$got );
725 local $Level = $Level + 1;
726 return $self->diag(<<"DIAGNOSTIC");
728 expected: anything else
734 $Test->isnt_eq($got, $dont_expect, $name);
736 Like Test::More's C<isnt()>. Checks if C<$got ne $dont_expect>. This is
741 $Test->isnt_num($got, $dont_expect, $name);
743 Like Test::More's C<isnt()>. Checks if C<$got ne $dont_expect>. This is
749 my( $self, $got, $dont_expect, $name ) = @_;
750 local $Level = $Level + 1;
752 if( !defined $got || !defined $dont_expect ) {
753 # undef only matches undef and nothing else
754 my $test = defined $got || defined $dont_expect;
756 $self->ok( $test, $name );
757 $self->_isnt_diag( $got, 'ne' ) unless $test;
761 return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
765 my( $self, $got, $dont_expect, $name ) = @_;
766 local $Level = $Level + 1;
768 if( !defined $got || !defined $dont_expect ) {
769 # undef only matches undef and nothing else
770 my $test = defined $got || defined $dont_expect;
772 $self->ok( $test, $name );
773 $self->_isnt_diag( $got, '!=' ) unless $test;
777 return $self->cmp_ok( $got, '!=', $dont_expect, $name );
782 $Test->like($this, qr/$regex/, $name);
783 $Test->like($this, '/$regex/', $name);
785 Like Test::More's C<like()>. Checks if $this matches the given C<$regex>.
787 You'll want to avoid C<qr//> if you want your tests to work before 5.005.
791 $Test->unlike($this, qr/$regex/, $name);
792 $Test->unlike($this, '/$regex/', $name);
794 Like Test::More's C<unlike()>. Checks if $this B<does not match> the
800 my( $self, $this, $regex, $name ) = @_;
802 local $Level = $Level + 1;
803 return $self->_regex_ok( $this, $regex, '=~', $name );
807 my( $self, $this, $regex, $name ) = @_;
809 local $Level = $Level + 1;
810 return $self->_regex_ok( $this, $regex, '!~', $name );
815 $Test->cmp_ok($this, $type, $that, $name);
817 Works just like Test::More's C<cmp_ok()>.
819 $Test->cmp_ok($big_num, '!=', $other_big_num);
823 my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
826 my( $self, $got, $type, $expect, $name ) = @_;
831 ## no critic (BuiltinFunctions::ProhibitStringyEval)
833 local( $@, $!, $SIG{__DIE__} ); # isolate eval
835 my($pack, $file, $line) = $self->caller();
838 #line 1 "cmp_ok [from $file line $line]"
839 \$got $type \$expect;
843 local $Level = $Level + 1;
844 my $ok = $self->ok( $test, $name );
846 # Treat overloaded objects as numbers if we're asked to do a
847 # numeric comparison.
849 = $numeric_cmps{$type}
853 $self->diag(<<"END") if $error;
854 An error occurred while using $type:
855 ------------------------------------
857 ------------------------------------
861 $self->$unoverload( \$got, \$expect );
863 if( $type =~ /^(eq|==)$/ ) {
864 $self->_is_diag( $got, $type, $expect );
866 elsif( $type =~ /^(ne|!=)$/ ) {
867 $self->_isnt_diag( $got, $type );
870 $self->_cmp_diag( $got, $type, $expect );
877 my( $self, $got, $type, $expect ) = @_;
879 $got = defined $got ? "'$got'" : 'undef';
880 $expect = defined $expect ? "'$expect'" : 'undef';
882 local $Level = $Level + 1;
883 return $self->diag(<<"DIAGNOSTIC");
890 sub _caller_context {
893 my( $pack, $file, $line ) = $self->caller(1);
896 $code .= "#line $line $file\n" if defined $file and defined $line;
904 =head2 Other Testing Methods
906 These are methods which are used in the course of writing a test but are not themselves tests.
912 $Test->BAIL_OUT($reason);
914 Indicates to the Test::Harness that things are going so badly all
915 testing should terminate. This includes running any additional test
918 It will exit with 255.
923 my( $self, $reason ) = @_;
925 $self->{Bailed_Out} = 1;
926 $self->_print("Bail out! $reason");
931 BAIL_OUT() used to be BAILOUT()
935 *BAILOUT = \&BAIL_OUT;
942 Skips the current test, reporting C<$why>.
947 my( $self, $why ) = @_;
949 $self->_unoverload_str( \$why );
951 lock( $self->{Curr_Test} );
952 $self->{Curr_Test}++;
954 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
965 $out .= " $self->{Curr_Test}" if $self->use_numbers;
967 $out .= " $why" if length $why;
978 $Test->todo_skip($why);
980 Like C<skip()>, only it will declare the test as failing and TODO. Similar
983 print "not ok $tnum # TODO $why\n";
988 my( $self, $why ) = @_;
991 lock( $self->{Curr_Test} );
992 $self->{Curr_Test}++;
994 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
1005 $out .= " $self->{Curr_Test}" if $self->use_numbers;
1006 $out .= " # TODO & SKIP $why\n";
1008 $self->_print($out);
1013 =begin _unimplemented
1018 $Test->skip_rest($reason);
1020 Like C<skip()>, only it skips all the rest of the tests you plan to run
1021 and terminates the test.
1023 If you're running under C<no_plan>, it skips once and terminates the
1031 =head2 Test building utility methods
1033 These methods are useful when writing your own test methods.
1037 =item B<maybe_regex>
1039 $Test->maybe_regex(qr/$regex/);
1040 $Test->maybe_regex('/$regex/');
1042 Convenience method for building testing functions that take regular
1043 expressions as arguments, but need to work before perl 5.005.
1045 Takes a quoted regular expression produced by C<qr//>, or a string
1046 representing a regular expression.
1048 Returns a Perl value which may be used instead of the corresponding
1049 regular expression, or C<undef> if its argument is not recognised.
1051 For example, a version of C<like()>, sans the useful diagnostic messages,
1052 could be written as:
1055 my ($self, $this, $regex, $name) = @_;
1056 my $usable_regex = $self->maybe_regex($regex);
1057 die "expecting regex, found '$regex'\n"
1058 unless $usable_regex;
1059 $self->ok($this =~ m/$usable_regex/, $name);
1065 my( $self, $regex ) = @_;
1066 my $usable_regex = undef;
1068 return $usable_regex unless defined $regex;
1073 if( _is_qr($regex) ) {
1074 $usable_regex = $regex;
1076 # Check for '/foo/' or 'm,foo,'
1077 elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
1078 ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
1081 $usable_regex = length $opts ? "(?$opts)$re" : $re;
1084 return $usable_regex;
1090 # is_regexp() checks for regexes in a robust manner, say if they're
1092 return re::is_regexp($regex) if defined &re::is_regexp;
1093 return ref $regex eq 'Regexp';
1097 my( $self, $this, $regex, $cmp, $name ) = @_;
1100 my $usable_regex = $self->maybe_regex($regex);
1101 unless( defined $usable_regex ) {
1102 local $Level = $Level + 1;
1103 $ok = $self->ok( 0, $name );
1104 $self->diag(" '$regex' doesn't look much like a regex to me.");
1109 ## no critic (BuiltinFunctions::ProhibitStringyEval)
1112 my $code = $self->_caller_context;
1114 local( $@, $!, $SIG{__DIE__} ); # isolate eval
1116 # Yes, it has to look like this or 5.4.5 won't see the #line
1118 # Don't ask me, man, I just work here.
1120 $code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
1122 $test = !$test if $cmp eq '!~';
1124 local $Level = $Level + 1;
1125 $ok = $self->ok( $test, $name );
1129 $this = defined $this ? "'$this'" : 'undef';
1130 my $match = $cmp eq '=~' ? "doesn't match" : "matches";
1132 local $Level = $Level + 1;
1133 $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex );
1143 # I'm not ready to publish this. It doesn't deal with array return
1144 # values from the code or context.
1150 my $return_from_code = $Test->try(sub { code });
1151 my($return_from_code, $error) = $Test->try(sub { code });
1153 Works like eval BLOCK except it ensures it has no effect on the rest
1154 of the test (ie. C<$@> is not set) nor is effected by outside
1155 interference (ie. C<$SIG{__DIE__}>) and works around some quirks in older
1158 C<$error> is what would normally be in C<$@>.
1160 It is suggested you use this in place of eval BLOCK.
1165 my( $self, $code, %opts ) = @_;
1170 local $!; # eval can mess up $!
1171 local $@; # don't set $@ in the test
1172 local $SIG{__DIE__}; # don't trip an outside DIE handler.
1173 $return = eval { $code->() };
1177 die $error if $error and $opts{die_on_fail};
1179 return wantarray ? ( $return, $error ) : $return;
1187 my $is_fh = $Test->is_fh($thing);
1189 Determines if the given C<$thing> can be used as a filehandle.
1195 my $maybe_fh = shift;
1196 return 0 unless defined $maybe_fh;
1198 return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
1199 return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
1201 return eval { $maybe_fh->isa("IO::Handle") } ||
1202 # 5.5.4's tied() and can() doesn't like getting undef
1203 eval { ( tied($maybe_fh) || '' )->can('TIEHANDLE') };
1216 $Test->level($how_high);
1218 How far up the call stack should C<$Test> look when reporting where the
1223 Setting L<$Test::Builder::Level> overrides. This is typically useful
1229 local $Test::Builder::Level = $Test::Builder::Level + 1;
1233 To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant.
1238 my( $self, $level ) = @_;
1240 if( defined $level ) {
1246 =item B<use_numbers>
1248 $Test->use_numbers($on_or_off);
1250 Whether or not the test should output numbers. That is, this if true:
1262 Most useful when you can't depend on the test output order, such as
1263 when threads or forking is involved.
1270 my( $self, $use_nums ) = @_;
1272 if( defined $use_nums ) {
1273 $self->{Use_Nums} = $use_nums;
1275 return $self->{Use_Nums};
1280 $Test->no_diag($no_diag);
1282 If set true no diagnostics will be printed. This includes calls to
1287 $Test->no_ending($no_ending);
1289 Normally, Test::Builder does some extra diagnostics when the test
1290 ends. It also changes the exit code as described below.
1292 If this is true, none of that will be done.
1296 $Test->no_header($no_header);
1298 If set to true, no "1..N" header will be printed.
1302 foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
1303 my $method = lc $attribute;
1306 my( $self, $no ) = @_;
1309 $self->{$attribute} = $no;
1311 return $self->{$attribute};
1314 no strict 'refs'; ## no critic
1315 *{ __PACKAGE__ . '::' . $method } = $code;
1322 Controlling where the test output goes.
1324 It's ok for your test to change where STDOUT and STDERR point to,
1325 Test::Builder's default output settings will not be affected.
1333 Prints out the given C<@msgs>. Like C<print>, arguments are simply
1336 Normally, it uses the C<failure_output()> handle, but if this is for a
1337 TODO test, the C<todo_output()> handle is used.
1339 Output will be indented and marked with a # so as not to interfere
1340 with test output. A newline will be put on the end if there isn't one
1343 We encourage using this rather than calling print directly.
1345 Returns false. Why? Because C<diag()> is often used in conjunction with
1346 a failing test (C<ok() || diag()>) it "passes through" the failure.
1348 return ok(...) || diag(...);
1351 Mark Fowler <mark@twoshortplanks.com>
1358 $self->_print_comment( $self->_diag_fh, @_ );
1365 Like C<diag()>, but it prints to the C<output()> handle so it will not
1366 normally be seen by the user except in verbose mode.
1373 $self->_print_comment( $self->output, @_ );
1379 local $Level = $Level + 1;
1380 return $self->in_todo ? $self->todo_output : $self->failure_output;
1383 sub _print_comment {
1384 my( $self, $fh, @msgs ) = @_;
1386 return if $self->no_diag;
1387 return unless @msgs;
1389 # Prevent printing headers when compiling (i.e. -c)
1392 # Smash args together like print does.
1393 # Convert undef to 'undef' so its readable.
1394 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1396 # Escape the beginning, _print will take care of the rest.
1399 local $Level = $Level + 1;
1400 $self->_print_to_fh( $fh, $msg );
1407 my @dump = $Test->explain(@msgs);
1409 Will dump the contents of any references in a human readable format.
1410 Handy for things like...
1412 is_deeply($have, $want) || diag explain $have;
1416 is_deeply($have, $want) || note explain $have;
1426 $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
1428 my $dumper = Data::Dumper->new( [$_] );
1429 $dumper->Indent(1)->Terse(1);
1430 $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
1441 $Test->_print(@msgs);
1443 Prints to the C<output()> filehandle.
1451 return $self->_print_to_fh( $self->output, @_ );
1455 my( $self, $fh, @msgs ) = @_;
1457 # Prevent printing headers when only compiling. Mostly for when
1458 # tests are deparsed with B::Deparse
1461 my $msg = join '', @msgs;
1463 local( $\, $", $, ) = ( undef, ' ', '' );
1465 # Escape each line after the first with a # so we don't
1466 # confuse Test::Harness.
1467 $msg =~ s{\n(?!\z)}{\n# }sg;
1469 # Stick a newline on the end if it needs it.
1470 $msg .= "\n" unless $msg =~ /\n\z/;
1472 return print $fh $msg;
1477 =item B<failure_output>
1479 =item B<todo_output>
1481 my $filehandle = $Test->output;
1482 $Test->output($filehandle);
1483 $Test->output($filename);
1484 $Test->output(\$scalar);
1486 These methods control where Test::Builder will print its output.
1487 They take either an open C<$filehandle>, a C<$filename> to open and write to
1488 or a C<$scalar> reference to append to. It will always return a C<$filehandle>.
1490 B<output> is where normal "ok/not ok" test output goes.
1494 B<failure_output> is where diagnostic output on test failures and
1495 C<diag()> goes. It is normally not read by Test::Harness and instead is
1496 displayed to the user.
1500 C<todo_output> is used instead of C<failure_output()> for the
1501 diagnostics of a failing TODO test. These will not be seen by the
1509 my( $self, $fh ) = @_;
1512 $self->{Out_FH} = $self->_new_fh($fh);
1514 return $self->{Out_FH};
1517 sub failure_output {
1518 my( $self, $fh ) = @_;
1521 $self->{Fail_FH} = $self->_new_fh($fh);
1523 return $self->{Fail_FH};
1527 my( $self, $fh ) = @_;
1530 $self->{Todo_FH} = $self->_new_fh($fh);
1532 return $self->{Todo_FH};
1537 my($file_or_fh) = shift;
1540 if( $self->is_fh($file_or_fh) ) {
1543 elsif( ref $file_or_fh eq 'SCALAR' ) {
1544 # Scalar refs as filehandles was added in 5.8.
1546 open $fh, ">>", $file_or_fh
1547 or $self->croak("Can't open scalar ref $file_or_fh: $!");
1549 # Emulate scalar ref filehandles with a tie.
1551 $fh = Test::Builder::IO::Scalar->new($file_or_fh)
1552 or $self->croak("Can't tie scalar ref $file_or_fh");
1556 open $fh, ">", $file_or_fh
1557 or $self->croak("Can't open test output log $file_or_fh: $!");
1566 my $old_fh = select $fh;
1573 my( $Testout, $Testerr );
1575 sub _dup_stdhandles {
1578 $self->_open_testhandles;
1580 # Set everything to unbuffered else plain prints to STDOUT will
1581 # come out in the wrong order from our own prints.
1582 _autoflush($Testout);
1583 _autoflush( \*STDOUT );
1584 _autoflush($Testerr);
1585 _autoflush( \*STDERR );
1587 $self->reset_outputs;
1592 sub _open_testhandles {
1595 return if $self->{Opened_Testhandles};
1597 # We dup STDOUT and STDERR so people can change them in their
1598 # test suites while still getting normal test output.
1599 open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
1600 open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!";
1602 # $self->_copy_io_layers( \*STDOUT, $Testout );
1603 # $self->_copy_io_layers( \*STDERR, $Testerr );
1605 $self->{Opened_Testhandles} = 1;
1610 sub _copy_io_layers {
1611 my( $self, $src, $dst ) = @_;
1616 my @src_layers = PerlIO::get_layers($src);
1618 binmode $dst, join " ", map ":$_", @src_layers if @src_layers;
1629 Resets all the output filehandles back to their defaults.
1636 $self->output ($Testout);
1637 $self->failure_output($Testerr);
1638 $self->todo_output ($Testout);
1645 $tb->carp(@message);
1647 Warns with C<@message> but the message will appear to come from the
1648 point where the original test function was called (C<< $tb->caller >>).
1652 $tb->croak(@message);
1654 Dies with C<@message> but the message will appear to come from the
1655 point where the original test function was called (C<< $tb->caller >>).
1659 sub _message_at_caller {
1662 local $Level = $Level + 1;
1663 my( $pack, $file, $line ) = $self->caller;
1664 return join( "", @_ ) . " at $file line $line.\n";
1669 return warn $self->_message_at_caller(@_);
1674 return die $self->_message_at_caller(@_);
1681 =head2 Test Status and Info
1685 =item B<current_test>
1687 my $curr_test = $Test->current_test;
1688 $Test->current_test($num);
1690 Gets/sets the current test number we're on. You usually shouldn't
1693 If set forward, the details of the missing tests are filled in as 'unknown'.
1694 if set backward, the details of the intervening tests are deleted. You
1695 can erase history if you really want to.
1700 my( $self, $num ) = @_;
1702 lock( $self->{Curr_Test} );
1703 if( defined $num ) {
1704 $self->{Curr_Test} = $num;
1706 # If the test counter is being pushed forward fill in the details.
1707 my $test_results = $self->{Test_Results};
1708 if( $num > @$test_results ) {
1709 my $start = @$test_results ? @$test_results : 0;
1710 for( $start .. $num - 1 ) {
1711 $test_results->[$_] = &share(
1715 reason => 'incrementing test number',
1722 # If backward, wipe history. Its their funeral.
1723 elsif( $num < @$test_results ) {
1724 $#{$test_results} = $num - 1;
1727 return $self->{Curr_Test};
1732 my @tests = $Test->summary;
1734 A simple summary of the tests so far. True for pass, false for fail.
1735 This is a logical pass/fail, so todos are passes.
1737 Of course, test #1 is $tests[0], etc...
1744 return map { $_->{'ok'} } @{ $self->{Test_Results} };
1749 my @tests = $Test->details;
1751 Like C<summary()>, but with a lot more detail.
1753 $tests[$test_num - 1] =
1754 { 'ok' => is the test considered a pass?
1755 actual_ok => did it literally say 'ok'?
1756 name => name of the test (if any)
1757 type => type of test (if any, see below).
1758 reason => reason for the above (if any)
1761 'ok' is true if Test::Harness will consider the test to be a pass.
1763 'actual_ok' is a reflection of whether or not the test literally
1764 printed 'ok' or 'not ok'. This is for examining the result of 'todo'
1767 'name' is the name of the test.
1769 'type' indicates if it was a special test. Normal tests have a type
1770 of ''. Type can be one of the following:
1774 todo_skip see todo_skip()
1777 Sometimes the Test::Builder test counter is incremented without it
1778 printing any test output, for example, when C<current_test()> is changed.
1779 In these cases, Test::Builder doesn't know the result of the test, so
1780 its type is 'unknown'. These details for these tests are filled in.
1781 They are considered ok, but the name and actual_ok is left C<undef>.
1783 For example "not ok 23 - hole count # TODO insufficient donuts" would
1784 result in this structure:
1786 $tests[22] = # 23 - 1, since arrays start from 0.
1787 { ok => 1, # logically, the test passed since its todo
1788 actual_ok => 0, # in absolute terms, it failed
1789 name => 'hole count',
1791 reason => 'insufficient donuts'
1798 return @{ $self->{Test_Results} };
1803 my $todo_reason = $Test->todo;
1804 my $todo_reason = $Test->todo($pack);
1806 If the current tests are considered "TODO" it will return the reason,
1807 if any. This reason can come from a C<$TODO> variable or the last call
1810 Since a TODO test does not need a reason, this function can return an
1811 empty string even when inside a TODO block. Use C<< $Test->in_todo >>
1812 to determine if you are currently inside a TODO block.
1814 C<todo()> is about finding the right package to look for C<$TODO> in. It's
1815 pretty good at guessing the right package to look at. It first looks for
1816 the caller based on C<$Level + 1>, since C<todo()> is usually called inside
1817 a test function. As a last resort it will use C<exported_to()>.
1819 Sometimes there is some confusion about where todo() should be looking
1820 for the C<$TODO> variable. If you want to be sure, tell it explicitly
1826 my( $self, $pack ) = @_;
1828 return $self->{Todo} if defined $self->{Todo};
1830 local $Level = $Level + 1;
1831 my $todo = $self->find_TODO($pack);
1832 return $todo if defined $todo;
1839 my $todo_reason = $Test->find_TODO();
1840 my $todo_reason = $Test->find_TODO($pack):
1842 Like C<todo()> but only returns the value of C<$TODO> ignoring
1848 my( $self, $pack ) = @_;
1850 $pack = $pack || $self->caller(1) || $self->exported_to;
1851 return unless $pack;
1853 no strict 'refs'; ## no critic
1854 return ${ $pack . '::TODO' };
1859 my $in_todo = $Test->in_todo;
1861 Returns true if the test is currently inside a TODO block.
1868 local $Level = $Level + 1;
1869 return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
1874 $Test->todo_start();
1875 $Test->todo_start($message);
1877 This method allows you declare all subsequent tests as TODO tests, up until
1878 the C<todo_end> method has been called.
1880 The C<TODO:> and C<$TODO> syntax is generally pretty good about figuring out
1881 whether or not we're in a TODO test. However, often we find that this is not
1882 possible to determine (such as when we want to use C<$TODO> but
1883 the tests are being executed in other packages which can't be inferred
1886 Note that you can use this to nest "todo" tests
1888 $Test->todo_start('working on this');
1890 $Test->todo_start('working on that');
1895 This is generally not recommended, but large testing systems often have weird
1898 We've tried to make this also work with the TODO: syntax, but it's not
1899 guaranteed and its use is also discouraged:
1902 local $TODO = 'We have work to do!';
1903 $Test->todo_start('working on this');
1905 $Test->todo_start('working on that');
1911 Pick one style or another of "TODO" to be on the safe side.
1917 my $message = @_ ? shift : '';
1919 $self->{Start_Todo}++;
1920 if( $self->in_todo ) {
1921 push @{ $self->{Todo_Stack} } => $self->todo;
1923 $self->{Todo} = $message;
1932 Stops running tests as "TODO" tests. This method is fatal if called without a
1933 preceding C<todo_start> method call.
1940 if( !$self->{Start_Todo} ) {
1941 $self->croak('todo_end() called without todo_start()');
1944 $self->{Start_Todo}--;
1946 if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
1947 $self->{Todo} = pop @{ $self->{Todo_Stack} };
1950 delete $self->{Todo};
1958 my $package = $Test->caller;
1959 my($pack, $file, $line) = $Test->caller;
1960 my($pack, $file, $line) = $Test->caller($height);
1962 Like the normal C<caller()>, except it reports according to your C<level()>.
1964 C<$height> will be added to the C<level()>.
1966 If C<caller()> winds up off the top of the stack it report the highest context.
1970 sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
1971 my( $self, $height ) = @_;
1974 my $level = $self->level + $height + 1;
1977 @caller = CORE::caller( $level );
1980 return wantarray ? @caller : $caller[0];
1991 =item B<_sanity_check>
1993 $self->_sanity_check();
1995 Runs a bunch of end of test sanity checks to make sure reality came
1996 through ok. If anything is wrong it will die with a fairly friendly
2005 $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
2006 $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
2007 'Somehow you got a different number of results than tests ran!' );
2014 $self->_whoa($check, $description);
2016 A sanity check, similar to C<assert()>. If the C<$check> is true, something
2017 has gone horribly wrong. It will die with the given C<$description> and
2018 a note to contact the author.
2023 my( $self, $check, $desc ) = @_;
2025 local $Level = $Level + 1;
2026 $self->croak(<<"WHOA");
2028 This should never happen! Please contact the author immediately!
2037 _my_exit($exit_num);
2039 Perl seems to have some trouble with exiting inside an C<END> block. 5.005_03
2040 and 5.6.1 both seem to do odd things. Instead, this function edits C<$?>
2041 directly. It should B<only> be called from inside an C<END> block. It
2042 doesn't actually exit, that's your job.
2047 $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
2061 my $real_exit_code = $?;
2063 # Don't bother with an ending if this is a forked copy. Only the parent
2064 # should do the ending.
2065 if( $self->{Original_Pid} != $$ ) {
2069 # Ran tests but never declared a plan or hit done_testing
2070 if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
2071 $self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
2074 # Exit if plan() was never called. This is so "require Test::Simple"
2076 if( !$self->{Have_Plan} ) {
2080 # Don't do an ending if we bailed out.
2081 if( $self->{Bailed_Out} ) {
2085 # Figure out if we passed or failed and print helpful messages.
2086 my $test_results = $self->{Test_Results};
2087 if(@$test_results) {
2088 # The plan? We have no plan.
2089 if( $self->{No_Plan} ) {
2090 $self->_output_plan($self->{Curr_Test}) unless $self->no_header;
2091 $self->{Expected_Tests} = $self->{Curr_Test};
2094 # Auto-extended arrays and elements which aren't explicitly
2095 # filled in with a shared reference will puke under 5.8.0
2096 # ithreads. So we have to fill them in by hand. :(
2097 my $empty_result = &share( {} );
2098 for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
2099 $test_results->[$idx] = $empty_result
2100 unless defined $test_results->[$idx];
2103 my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
2105 my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
2107 if( $num_extra != 0 ) {
2108 my $s = $self->{Expected_Tests} == 1 ? '' : 's';
2109 $self->diag(<<"FAIL");
2110 Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}.
2115 my $num_tests = $self->{Curr_Test};
2116 my $s = $num_failed == 1 ? '' : 's';
2118 my $qualifier = $num_extra == 0 ? '' : ' run';
2120 $self->diag(<<"FAIL");
2121 Looks like you failed $num_failed test$s of $num_tests$qualifier.
2125 if($real_exit_code) {
2126 $self->diag(<<"FAIL");
2127 Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
2130 _my_exit($real_exit_code) && return;
2135 $exit_code = $num_failed <= 254 ? $num_failed : 254;
2137 elsif( $num_extra != 0 ) {
2144 _my_exit($exit_code) && return;
2146 elsif( $self->{Skip_All} ) {
2147 _my_exit(0) && return;
2149 elsif($real_exit_code) {
2150 $self->diag(<<"FAIL");
2151 Looks like your test exited with $real_exit_code before it could output anything.
2153 _my_exit($real_exit_code) && return;
2156 $self->diag("No tests run!\n");
2157 _my_exit(255) && return;
2160 $self->_whoa( 1, "We fell off the end of _ending()" );
2164 $Test->_ending if defined $Test and !$Test->no_ending;
2169 If all your tests passed, Test::Builder will exit with zero (which is
2170 normal). If anything failed it will exit with how many failed. If
2171 you run less (or more) tests than you planned, the missing (or extras)
2172 will be considered failures. If no tests were ever run Test::Builder
2173 will throw a warning and exit with 255. If the test died, even after
2174 having successfully completed all its tests, it will still be
2175 considered a failure and will exit with 255.
2177 So the exit codes are...
2179 0 all tests successful
2180 255 test died or all passed but wrong # of tests run
2181 any other number how many failed (including missing or extras)
2183 If you fail more than 254 tests, it will be reported as 254.
2187 In perl 5.8.1 and later, Test::Builder is thread-safe. The test
2188 number is shared amongst all threads. This means if one thread sets
2189 the test number using C<current_test()> they will all be effected.
2191 While versions earlier than 5.8.1 had threads they contain too many
2194 Test::Builder is only thread-aware if threads.pm is loaded I<before>
2199 An informative hash, accessable via C<<details()>>, is stored for each
2200 test you perform. So memory usage will scale linearly with each test
2201 run. Although this is not a problem for most test suites, it can
2202 become an issue if you do large (hundred thousands to million)
2203 combinatorics tests in the same run.
2205 In such cases, you are advised to either split the test file into smaller
2206 ones, or use a reverse approach, doing "normal" (code) compares and
2207 triggering fail() should anything go unexpected.
2209 Future versions of Test::Builder will have a way to turn history off.
2214 CPAN can provide the best examples. Test::Simple, Test::More,
2215 Test::Exception and Test::Differences all use Test::Builder.
2219 Test::Simple, Test::More, Test::Harness
2223 Original code by chromatic, maintained by Michael G Schwern
2224 E<lt>schwern@pobox.comE<gt>
2228 Copyright 2002-2008 by chromatic E<lt>chromatic@wgz.orgE<gt> and
2229 Michael G Schwern E<lt>schwern@pobox.comE<gt>.
2231 This program is free software; you can redistribute it and/or
2232 modify it under the same terms as Perl itself.
2234 See F<http://www.perl.com/perl/misc/Artistic.html>