2 # $Id: /mirror/googlecode/test-more-trunk/lib/Test/Builder.pm 67223 2008-10-15T03:08:18.888155Z schwern $
9 $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
11 # Make Test::Builder thread-safe for ithreads.
14 # Load threads::shared when threads are turned on.
15 # 5.8.0's threads are so busted we no longer support them.
16 if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
17 require threads::shared;
19 # Hack around YET ANOTHER threads::shared bug. It would
20 # occassionally forget the contents of the variable when sharing it.
21 # So we first copy the data, then share, then put our copy back.
22 *share = sub (\[$@%]) {
26 if( $type eq 'HASH' ) {
29 elsif( $type eq 'ARRAY' ) {
32 elsif( $type eq 'SCALAR' ) {
36 die( "Unknown type: " . $type );
39 $_[0] = &threads::shared::share( $_[0] );
41 if( $type eq 'HASH' ) {
44 elsif( $type eq 'ARRAY' ) {
47 elsif( $type eq 'SCALAR' ) {
51 die( "Unknown type: " . $type );
57 # 5.8.0's threads::shared is busted when threads are off
58 # and earlier Perls just don't have that module at all.
60 *share = sub { return $_[0] };
67 Test::Builder - Backend for building test libraries
71 package My::Test::Module;
72 use base 'Test::Builder::Module';
74 my $CLASS = __PACKAGE__;
77 my($test, $name) = @_;
78 my $tb = $CLASS->builder;
80 $tb->ok($test, $name);
86 Test::Simple and Test::More have proven to be popular testing modules,
87 but they're not always flexible enough. Test::Builder provides the a
88 building block upon which to write your own test libraries I<which can
97 my $Test = Test::Builder->new;
99 Returns a Test::Builder object representing the current state of the
102 Since you only run one test per program C<new> always returns the same
103 Test::Builder object. No matter how many times you call new(), you're
104 getting the same object. This is called a singleton. This is done so that
105 multiple modules share such global information as the test counter and
106 where test output is going.
108 If you want a completely new Test::Builder object different from the
109 singleton, use C<create>.
113 my $Test = Test::Builder->new;
117 $Test ||= $class->create;
123 my $Test = Test::Builder->create;
125 Ok, so there can be more than one Test::Builder object and this is how
126 you get it. You might use this instead of C<new()> if you're testing
127 a Test::Builder based module, but otherwise you probably want C<new>.
129 B<NOTE>: the implementation is not complete. C<level>, for example, is
130 still shared amongst B<all> Test::Builder objects, even ones created using
131 this method. Also, the method name may change in the future.
138 my $self = bless {}, $class;
148 Reinitializes the Test::Builder singleton to its original state.
149 Mostly useful for tests run in persistent environments where the same
150 test might be run multiple times in the same process.
156 sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
159 # We leave this a global because it has to be localized and localizing
160 # hash keys is just asking for pain. Also, it was documented.
163 $self->{Have_Plan} = 0;
164 $self->{No_Plan} = 0;
165 $self->{Original_Pid} = $$;
167 share( $self->{Curr_Test} );
168 $self->{Curr_Test} = 0;
169 $self->{Test_Results} = &share( [] );
171 $self->{Exported_To} = undef;
172 $self->{Expected_Tests} = 0;
174 $self->{Skip_All} = 0;
176 $self->{Use_Nums} = 1;
178 $self->{No_Header} = 0;
179 $self->{No_Ending} = 0;
181 $self->{Todo} = undef;
182 $self->{Todo_Stack} = [];
183 $self->{Start_Todo} = 0;
185 $self->_dup_stdhandles;
192 =head2 Setting up tests
194 These methods are for setting up tests and declaring how many there
195 are. You usually only want to call one of these methods.
201 $Test->plan('no_plan');
202 $Test->plan( skip_all => $reason );
203 $Test->plan( tests => $num_tests );
205 A convenient way to set up your tests. Call this and Test::Builder
206 will print the appropriate headers and take the appropriate actions.
208 If you call plan(), don't call any of the other methods below.
213 my( $self, $cmd, $arg ) = @_;
217 local $Level = $Level + 1;
219 $self->croak("You tried to plan twice")
220 if $self->{Have_Plan};
222 if( $cmd eq 'no_plan' ) {
223 $self->carp("no_plan takes no arguments") if $arg;
226 elsif( $cmd eq 'skip_all' ) {
227 return $self->skip_all($arg);
229 elsif( $cmd eq 'tests' ) {
231 local $Level = $Level + 1;
232 return $self->expected_tests($arg);
234 elsif( !defined $arg ) {
235 $self->croak("Got an undefined number of tests");
238 $self->croak("You said to run 0 tests");
242 my @args = grep { defined } ( $cmd, $arg );
243 $self->croak("plan() doesn't understand @args");
249 =item B<expected_tests>
251 my $max = $Test->expected_tests;
252 $Test->expected_tests($max);
254 Gets/sets the # of tests we expect this test to run and prints out
255 the appropriate headers.
264 $self->croak("Number of tests must be a positive integer. You gave it '$max'")
265 unless $max =~ /^\+?\d+$/;
267 $self->{Expected_Tests} = $max;
268 $self->{Have_Plan} = 1;
270 $self->_print("1..$max\n") unless $self->no_header;
272 return $self->{Expected_Tests};
279 Declares that this test will run an indeterminate # of tests.
286 $self->{No_Plan} = 1;
287 $self->{Have_Plan} = 1;
294 $plan = $Test->has_plan
296 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).
303 return( $self->{Expected_Tests} ) if $self->{Expected_Tests};
304 return('no_plan') if $self->{No_Plan};
311 $Test->skip_all($reason);
313 Skips all the tests, using the given $reason. Exits immediately with 0.
318 my( $self, $reason ) = @_;
321 $out .= " # Skip $reason" if $reason;
324 $self->{Skip_All} = 1;
326 $self->_print($out) unless $self->no_header;
332 my $pack = $Test->exported_to;
333 $Test->exported_to($pack);
335 Tells Test::Builder what package you exported your functions to.
337 This method isn't terribly useful since modules which share the same
338 Test::Builder object might get exported to different packages and only
339 the last one will be honored.
344 my( $self, $pack ) = @_;
346 if( defined $pack ) {
347 $self->{Exported_To} = $pack;
349 return $self->{Exported_To};
356 These actually run the tests, analogous to the functions in Test::More.
358 They all return true if the test passed, false if the test failed.
360 $name is always optional.
366 $Test->ok($test, $name);
368 Your basic test. Pass if $test is true, fail if $test is false. Just
369 like Test::Simple's ok().
374 my( $self, $test, $name ) = @_;
376 # $test might contain an object which we don't want to accidentally
377 # store, so we turn it into a boolean.
378 $test = $test ? 1 : 0;
382 lock $self->{Curr_Test};
383 $self->{Curr_Test}++;
385 # In case $name is a string overloaded object, force it to stringify.
386 $self->_unoverload_str( \$name );
388 $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
389 You named your test '$name'. You shouldn't use numbers for your test names.
393 # Capture the value of $TODO for the rest of this ok() call
394 # so it can more easily be found by other routines.
395 my $todo = $self->todo();
396 my $in_todo = $self->in_todo;
397 local $self->{Todo} = $todo if $in_todo;
399 $self->_unoverload_str( \$todo );
402 my $result = &share( {} );
406 @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
409 @$result{ 'ok', 'actual_ok' } = ( 1, $test );
413 $out .= " $self->{Curr_Test}" if $self->use_numbers;
415 if( defined $name ) {
416 $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
418 $result->{name} = $name;
421 $result->{name} = '';
424 if( $self->in_todo ) {
425 $out .= " # TODO $todo";
426 $result->{reason} = $todo;
427 $result->{type} = 'todo';
430 $result->{reason} = '';
431 $result->{type} = '';
434 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
440 my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
441 $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
443 my( undef, $file, $line ) = $self->caller;
444 if( defined $name ) {
445 $self->diag(qq[ $msg test '$name'\n]);
446 $self->diag(qq[ at $file line $line.\n]);
449 $self->diag(qq[ $msg test at $file line $line.\n]);
453 return $test ? 1 : 0;
460 $self->_try(sub { require overload; }, die_on_fail => 1);
462 foreach my $thing (@_) {
463 if( $self->_is_object($$thing) ) {
464 if( my $string_meth = overload::Method( $$thing, $type ) ) {
465 $$thing = $$thing->$string_meth();
474 my( $self, $thing ) = @_;
476 return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
479 sub _unoverload_str {
482 return $self->_unoverload( q[""], @_ );
485 sub _unoverload_num {
488 $self->_unoverload( '0+', @_ );
491 next unless $self->_is_dualvar($$val);
498 # This is a hack to detect a dualvar such as $!
500 my( $self, $val ) = @_;
502 # Objects are not dualvars.
503 return 0 if ref $val;
505 no warnings 'numeric';
506 my $numval = $val + 0;
507 return $numval != 0 and $numval ne $val ? 1 : 0;
512 $Test->is_eq($got, $expected, $name);
514 Like Test::More's is(). Checks if $got eq $expected. This is the
519 $Test->is_num($got, $expected, $name);
521 Like Test::More's is(). Checks if $got == $expected. This is the
527 my( $self, $got, $expect, $name ) = @_;
528 local $Level = $Level + 1;
530 $self->_unoverload_str( \$got, \$expect );
532 if( !defined $got || !defined $expect ) {
533 # undef only matches undef and nothing else
534 my $test = !defined $got && !defined $expect;
536 $self->ok( $test, $name );
537 $self->_is_diag( $got, 'eq', $expect ) unless $test;
541 return $self->cmp_ok( $got, 'eq', $expect, $name );
545 my( $self, $got, $expect, $name ) = @_;
546 local $Level = $Level + 1;
548 $self->_unoverload_num( \$got, \$expect );
550 if( !defined $got || !defined $expect ) {
551 # undef only matches undef and nothing else
552 my $test = !defined $got && !defined $expect;
554 $self->ok( $test, $name );
555 $self->_is_diag( $got, '==', $expect ) unless $test;
559 return $self->cmp_ok( $got, '==', $expect, $name );
563 my( $self, $type, $val ) = @_;
565 if( defined $$val ) {
566 if( $type eq 'eq' or $type eq 'ne' ) {
567 # quote and force string context
571 # force numeric context
572 $self->_unoverload_num($val);
583 my( $self, $got, $type, $expect ) = @_;
585 $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
587 local $Level = $Level + 1;
588 return $self->diag(<<"DIAGNOSTIC");
596 my( $self, $got, $type ) = @_;
598 $self->_diag_fmt( $type, \$got );
600 local $Level = $Level + 1;
601 return $self->diag(<<"DIAGNOSTIC");
603 expected: anything else
609 $Test->isnt_eq($got, $dont_expect, $name);
611 Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
616 $Test->isnt_num($got, $dont_expect, $name);
618 Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
624 my( $self, $got, $dont_expect, $name ) = @_;
625 local $Level = $Level + 1;
627 if( !defined $got || !defined $dont_expect ) {
628 # undef only matches undef and nothing else
629 my $test = defined $got || defined $dont_expect;
631 $self->ok( $test, $name );
632 $self->_isnt_diag( $got, 'ne' ) unless $test;
636 return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
640 my( $self, $got, $dont_expect, $name ) = @_;
641 local $Level = $Level + 1;
643 if( !defined $got || !defined $dont_expect ) {
644 # undef only matches undef and nothing else
645 my $test = defined $got || defined $dont_expect;
647 $self->ok( $test, $name );
648 $self->_isnt_diag( $got, '!=' ) unless $test;
652 return $self->cmp_ok( $got, '!=', $dont_expect, $name );
657 $Test->like($this, qr/$regex/, $name);
658 $Test->like($this, '/$regex/', $name);
660 Like Test::More's like(). Checks if $this matches the given $regex.
662 You'll want to avoid qr// if you want your tests to work before 5.005.
666 $Test->unlike($this, qr/$regex/, $name);
667 $Test->unlike($this, '/$regex/', $name);
669 Like Test::More's unlike(). Checks if $this B<does not match> the
675 my( $self, $this, $regex, $name ) = @_;
677 local $Level = $Level + 1;
678 return $self->_regex_ok( $this, $regex, '=~', $name );
682 my( $self, $this, $regex, $name ) = @_;
684 local $Level = $Level + 1;
685 return $self->_regex_ok( $this, $regex, '!~', $name );
690 $Test->cmp_ok($this, $type, $that, $name);
692 Works just like Test::More's cmp_ok().
694 $Test->cmp_ok($big_num, '!=', $other_big_num);
698 my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
701 my( $self, $got, $type, $expect, $name ) = @_;
706 ## no critic (BuiltinFunctions::ProhibitStringyEval)
708 local( $@, $!, $SIG{__DIE__} ); # isolate eval
710 my($pack, $file, $line) = $self->caller();
713 #line 1 "cmp_ok [from $file line $line]"
714 \$got $type \$expect;
718 local $Level = $Level + 1;
719 my $ok = $self->ok( $test, $name );
721 # Treat overloaded objects as numbers if we're asked to do a
722 # numeric comparison.
724 = $numeric_cmps{$type}
728 $self->diag(<<"END") if $error;
729 An error occurred while using $type:
730 ------------------------------------
732 ------------------------------------
736 $self->$unoverload( \$got, \$expect );
738 if( $type =~ /^(eq|==)$/ ) {
739 $self->_is_diag( $got, $type, $expect );
741 elsif( $type =~ /^(ne|!=)$/ ) {
742 $self->_isnt_diag( $got, $type );
745 $self->_cmp_diag( $got, $type, $expect );
752 my( $self, $got, $type, $expect ) = @_;
754 $got = defined $got ? "'$got'" : 'undef';
755 $expect = defined $expect ? "'$expect'" : 'undef';
757 local $Level = $Level + 1;
758 return $self->diag(<<"DIAGNOSTIC");
765 sub _caller_context {
768 my( $pack, $file, $line ) = $self->caller(1);
771 $code .= "#line $line $file\n" if defined $file and defined $line;
779 =head2 Other Testing Methods
781 These are methods which are used in the course of writing a test but are not themselves tests.
787 $Test->BAIL_OUT($reason);
789 Indicates to the Test::Harness that things are going so badly all
790 testing should terminate. This includes running any additional test
793 It will exit with 255.
798 my( $self, $reason ) = @_;
800 $self->{Bailed_Out} = 1;
801 $self->_print("Bail out! $reason");
806 BAIL_OUT() used to be BAILOUT()
810 *BAILOUT = \&BAIL_OUT;
817 Skips the current test, reporting $why.
822 my( $self, $why ) = @_;
824 $self->_unoverload_str( \$why );
828 lock( $self->{Curr_Test} );
829 $self->{Curr_Test}++;
831 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
842 $out .= " $self->{Curr_Test}" if $self->use_numbers;
844 $out .= " $why" if length $why;
855 $Test->todo_skip($why);
857 Like skip(), only it will declare the test as failing and TODO. Similar
860 print "not ok $tnum # TODO $why\n";
865 my( $self, $why ) = @_;
870 lock( $self->{Curr_Test} );
871 $self->{Curr_Test}++;
873 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
884 $out .= " $self->{Curr_Test}" if $self->use_numbers;
885 $out .= " # TODO & SKIP $why\n";
892 =begin _unimplemented
897 $Test->skip_rest($reason);
899 Like skip(), only it skips all the rest of the tests you plan to run
900 and terminates the test.
902 If you're running under no_plan, it skips once and terminates the
910 =head2 Test building utility methods
912 These methods are useful when writing your own test methods.
918 $Test->maybe_regex(qr/$regex/);
919 $Test->maybe_regex('/$regex/');
921 Convenience method for building testing functions that take regular
922 expressions as arguments, but need to work before perl 5.005.
924 Takes a quoted regular expression produced by qr//, or a string
925 representing a regular expression.
927 Returns a Perl value which may be used instead of the corresponding
928 regular expression, or undef if its argument is not recognised.
930 For example, a version of like(), sans the useful diagnostic messages,
934 my ($self, $this, $regex, $name) = @_;
935 my $usable_regex = $self->maybe_regex($regex);
936 die "expecting regex, found '$regex'\n"
937 unless $usable_regex;
938 $self->ok($this =~ m/$usable_regex/, $name);
944 my( $self, $regex ) = @_;
945 my $usable_regex = undef;
947 return $usable_regex unless defined $regex;
952 if( _is_qr($regex) ) {
953 $usable_regex = $regex;
955 # Check for '/foo/' or 'm,foo,'
956 elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
957 ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
960 $usable_regex = length $opts ? "(?$opts)$re" : $re;
963 return $usable_regex;
969 # is_regexp() checks for regexes in a robust manner, say if they're
971 return re::is_regexp($regex) if defined &re::is_regexp;
972 return ref $regex eq 'Regexp';
976 my( $self, $this, $regex, $cmp, $name ) = @_;
979 my $usable_regex = $self->maybe_regex($regex);
980 unless( defined $usable_regex ) {
981 local $Level = $Level + 1;
982 $ok = $self->ok( 0, $name );
983 $self->diag(" '$regex' doesn't look much like a regex to me.");
988 ## no critic (BuiltinFunctions::ProhibitStringyEval)
991 my $code = $self->_caller_context;
993 local( $@, $!, $SIG{__DIE__} ); # isolate eval
995 # Yes, it has to look like this or 5.4.5 won't see the #line
997 # Don't ask me, man, I just work here.
999 $code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
1001 $test = !$test if $cmp eq '!~';
1003 local $Level = $Level + 1;
1004 $ok = $self->ok( $test, $name );
1008 $this = defined $this ? "'$this'" : 'undef';
1009 my $match = $cmp eq '=~' ? "doesn't match" : "matches";
1011 local $Level = $Level + 1;
1012 $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex );
1022 # I'm not ready to publish this. It doesn't deal with array return
1023 # values from the code or context.
1029 my $return_from_code = $Test->try(sub { code });
1030 my($return_from_code, $error) = $Test->try(sub { code });
1032 Works like eval BLOCK except it ensures it has no effect on the rest
1033 of the test (ie. $@ is not set) nor is effected by outside
1034 interference (ie. $SIG{__DIE__}) and works around some quirks in older
1037 $error is what would normally be in $@.
1039 It is suggested you use this in place of eval BLOCK.
1044 my( $self, $code, %opts ) = @_;
1049 local $!; # eval can mess up $!
1050 local $@; # don't set $@ in the test
1051 local $SIG{__DIE__}; # don't trip an outside DIE handler.
1052 $return = eval { $code->() };
1056 die $error if $error and $opts{die_on_fail};
1058 return wantarray ? ( $return, $error ) : $return;
1066 my $is_fh = $Test->is_fh($thing);
1068 Determines if the given $thing can be used as a filehandle.
1074 my $maybe_fh = shift;
1075 return 0 unless defined $maybe_fh;
1077 return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
1078 return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
1080 return eval { $maybe_fh->isa("IO::Handle") } ||
1081 # 5.5.4's tied() and can() doesn't like getting undef
1082 eval { ( tied($maybe_fh) || '' )->can('TIEHANDLE') };
1095 $Test->level($how_high);
1097 How far up the call stack should $Test look when reporting where the
1102 Setting L<$Test::Builder::Level> overrides. This is typically useful
1108 local $Test::Builder::Level = $Test::Builder::Level + 1;
1112 To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant.
1117 my( $self, $level ) = @_;
1119 if( defined $level ) {
1125 =item B<use_numbers>
1127 $Test->use_numbers($on_or_off);
1129 Whether or not the test should output numbers. That is, this if true:
1141 Most useful when you can't depend on the test output order, such as
1142 when threads or forking is involved.
1149 my( $self, $use_nums ) = @_;
1151 if( defined $use_nums ) {
1152 $self->{Use_Nums} = $use_nums;
1154 return $self->{Use_Nums};
1159 $Test->no_diag($no_diag);
1161 If set true no diagnostics will be printed. This includes calls to
1166 $Test->no_ending($no_ending);
1168 Normally, Test::Builder does some extra diagnostics when the test
1169 ends. It also changes the exit code as described below.
1171 If this is true, none of that will be done.
1175 $Test->no_header($no_header);
1177 If set to true, no "1..N" header will be printed.
1181 foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
1182 my $method = lc $attribute;
1185 my( $self, $no ) = @_;
1188 $self->{$attribute} = $no;
1190 return $self->{$attribute};
1193 no strict 'refs'; ## no critic
1194 *{ __PACKAGE__ . '::' . $method } = $code;
1201 Controlling where the test output goes.
1203 It's ok for your test to change where STDOUT and STDERR point to,
1204 Test::Builder's default output settings will not be affected.
1212 Prints out the given @msgs. Like C<print>, arguments are simply
1215 Normally, it uses the failure_output() handle, but if this is for a
1216 TODO test, the todo_output() handle is used.
1218 Output will be indented and marked with a # so as not to interfere
1219 with test output. A newline will be put on the end if there isn't one
1222 We encourage using this rather than calling print directly.
1224 Returns false. Why? Because diag() is often used in conjunction with
1225 a failing test (C<ok() || diag()>) it "passes through" the failure.
1227 return ok(...) || diag(...);
1230 Mark Fowler <mark@twoshortplanks.com>
1237 $self->_print_comment( $self->_diag_fh, @_ );
1244 Like diag(), but it prints to the C<output()> handle so it will not
1245 normally be seen by the user except in verbose mode.
1252 $self->_print_comment( $self->output, @_ );
1258 local $Level = $Level + 1;
1259 return $self->in_todo ? $self->todo_output : $self->failure_output;
1262 sub _print_comment {
1263 my( $self, $fh, @msgs ) = @_;
1265 return if $self->no_diag;
1266 return unless @msgs;
1268 # Prevent printing headers when compiling (i.e. -c)
1271 # Smash args together like print does.
1272 # Convert undef to 'undef' so its readable.
1273 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1275 # Escape the beginning, _print will take care of the rest.
1278 local $Level = $Level + 1;
1279 $self->_print_to_fh( $fh, $msg );
1286 my @dump = $Test->explain(@msgs);
1288 Will dump the contents of any references in a human readable format.
1289 Handy for things like...
1291 is_deeply($have, $want) || diag explain $have;
1295 is_deeply($have, $want) || note explain $have;
1305 $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
1307 my $dumper = Data::Dumper->new( [$_] );
1308 $dumper->Indent(1)->Terse(1);
1309 $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
1320 $Test->_print(@msgs);
1322 Prints to the output() filehandle.
1330 return $self->_print_to_fh( $self->output, @_ );
1334 my( $self, $fh, @msgs ) = @_;
1336 # Prevent printing headers when only compiling. Mostly for when
1337 # tests are deparsed with B::Deparse
1340 my $msg = join '', @msgs;
1342 local( $\, $", $, ) = ( undef, ' ', '' );
1344 # Escape each line after the first with a # so we don't
1345 # confuse Test::Harness.
1346 $msg =~ s{\n(?!\z)}{\n# }sg;
1348 # Stick a newline on the end if it needs it.
1349 $msg .= "\n" unless $msg =~ /\n\z/;
1351 return print $fh $msg;
1357 $Test->output($file);
1359 Where normal "ok/not ok" test output should go.
1363 =item B<failure_output>
1365 $Test->failure_output($fh);
1366 $Test->failure_output($file);
1368 Where diagnostic output on test failures and diag() should go.
1372 =item B<todo_output>
1374 $Test->todo_output($fh);
1375 $Test->todo_output($file);
1377 Where diagnostics about todo test failures and diag() should go.
1384 my( $self, $fh ) = @_;
1387 $self->{Out_FH} = $self->_new_fh($fh);
1389 return $self->{Out_FH};
1392 sub failure_output {
1393 my( $self, $fh ) = @_;
1396 $self->{Fail_FH} = $self->_new_fh($fh);
1398 return $self->{Fail_FH};
1402 my( $self, $fh ) = @_;
1405 $self->{Todo_FH} = $self->_new_fh($fh);
1407 return $self->{Todo_FH};
1412 my($file_or_fh) = shift;
1415 if( $self->is_fh($file_or_fh) ) {
1419 open $fh, ">", $file_or_fh
1420 or $self->croak("Can't open test output log $file_or_fh: $!");
1429 my $old_fh = select $fh;
1436 my( $Testout, $Testerr );
1438 sub _dup_stdhandles {
1441 $self->_open_testhandles;
1443 # Set everything to unbuffered else plain prints to STDOUT will
1444 # come out in the wrong order from our own prints.
1445 _autoflush($Testout);
1446 _autoflush( \*STDOUT );
1447 _autoflush($Testerr);
1448 _autoflush( \*STDERR );
1450 $self->reset_outputs;
1455 my $Opened_Testhandles = 0;
1457 sub _open_testhandles {
1460 return if $Opened_Testhandles;
1462 # We dup STDOUT and STDERR so people can change them in their
1463 # test suites while still getting normal test output.
1464 open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
1465 open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!";
1467 # $self->_copy_io_layers( \*STDOUT, $Testout );
1468 # $self->_copy_io_layers( \*STDERR, $Testerr );
1470 $Opened_Testhandles = 1;
1475 sub _copy_io_layers {
1476 my( $self, $src, $dst ) = @_;
1481 my @src_layers = PerlIO::get_layers($src);
1483 binmode $dst, join " ", map ":$_", @src_layers if @src_layers;
1494 Resets all the output filehandles back to their defaults.
1501 $self->output ($Testout);
1502 $self->failure_output($Testerr);
1503 $self->todo_output ($Testout);
1510 $tb->carp(@message);
1512 Warns with C<@message> but the message will appear to come from the
1513 point where the original test function was called (C<$tb->caller>).
1517 $tb->croak(@message);
1519 Dies with C<@message> but the message will appear to come from the
1520 point where the original test function was called (C<$tb->caller>).
1524 sub _message_at_caller {
1527 local $Level = $Level + 1;
1528 my( $pack, $file, $line ) = $self->caller;
1529 return join( "", @_ ) . " at $file line $line.\n";
1534 return warn $self->_message_at_caller(@_);
1539 return die $self->_message_at_caller(@_);
1545 unless( $self->{Have_Plan} ) {
1546 local $Level = $Level + 2;
1547 $self->croak("You tried to run a test without a plan");
1556 =head2 Test Status and Info
1560 =item B<current_test>
1562 my $curr_test = $Test->current_test;
1563 $Test->current_test($num);
1565 Gets/sets the current test number we're on. You usually shouldn't
1568 If set forward, the details of the missing tests are filled in as 'unknown'.
1569 if set backward, the details of the intervening tests are deleted. You
1570 can erase history if you really want to.
1575 my( $self, $num ) = @_;
1577 lock( $self->{Curr_Test} );
1578 if( defined $num ) {
1579 $self->croak("Can't change the current test number without a plan!")
1580 unless $self->{Have_Plan};
1582 $self->{Curr_Test} = $num;
1584 # If the test counter is being pushed forward fill in the details.
1585 my $test_results = $self->{Test_Results};
1586 if( $num > @$test_results ) {
1587 my $start = @$test_results ? @$test_results : 0;
1588 for( $start .. $num - 1 ) {
1589 $test_results->[$_] = &share(
1593 reason => 'incrementing test number',
1600 # If backward, wipe history. Its their funeral.
1601 elsif( $num < @$test_results ) {
1602 $#{$test_results} = $num - 1;
1605 return $self->{Curr_Test};
1610 my @tests = $Test->summary;
1612 A simple summary of the tests so far. True for pass, false for fail.
1613 This is a logical pass/fail, so todos are passes.
1615 Of course, test #1 is $tests[0], etc...
1622 return map { $_->{'ok'} } @{ $self->{Test_Results} };
1627 my @tests = $Test->details;
1629 Like summary(), but with a lot more detail.
1631 $tests[$test_num - 1] =
1632 { 'ok' => is the test considered a pass?
1633 actual_ok => did it literally say 'ok'?
1634 name => name of the test (if any)
1635 type => type of test (if any, see below).
1636 reason => reason for the above (if any)
1639 'ok' is true if Test::Harness will consider the test to be a pass.
1641 'actual_ok' is a reflection of whether or not the test literally
1642 printed 'ok' or 'not ok'. This is for examining the result of 'todo'
1645 'name' is the name of the test.
1647 'type' indicates if it was a special test. Normal tests have a type
1648 of ''. Type can be one of the following:
1652 todo_skip see todo_skip()
1655 Sometimes the Test::Builder test counter is incremented without it
1656 printing any test output, for example, when current_test() is changed.
1657 In these cases, Test::Builder doesn't know the result of the test, so
1658 its type is 'unknown'. These details for these tests are filled in.
1659 They are considered ok, but the name and actual_ok is left undef.
1661 For example "not ok 23 - hole count # TODO insufficient donuts" would
1662 result in this structure:
1664 $tests[22] = # 23 - 1, since arrays start from 0.
1665 { ok => 1, # logically, the test passed since it's todo
1666 actual_ok => 0, # in absolute terms, it failed
1667 name => 'hole count',
1669 reason => 'insufficient donuts'
1676 return @{ $self->{Test_Results} };
1681 my $todo_reason = $Test->todo;
1682 my $todo_reason = $Test->todo($pack);
1684 If the current tests are considered "TODO" it will return the reason,
1685 if any. This reason can come from a $TODO variable or the last call
1686 to C<<todo_start()>>.
1688 Since a TODO test does not need a reason, this function can return an
1689 empty string even when inside a TODO block. Use C<<$Test->in_todo>>
1690 to determine if you are currently inside a TODO block.
1692 todo() is about finding the right package to look for $TODO in. It's
1693 pretty good at guessing the right package to look at. It first looks for
1694 the caller based on C<$Level + 1>, since C<todo()> is usually called inside
1695 a test function. As a last resort it will use C<exported_to()>.
1697 Sometimes there is some confusion about where todo() should be looking
1698 for the $TODO variable. If you want to be sure, tell it explicitly
1704 my( $self, $pack ) = @_;
1706 return $self->{Todo} if defined $self->{Todo};
1708 local $Level = $Level + 1;
1709 my $todo = $self->find_TODO($pack);
1710 return $todo if defined $todo;
1717 my $todo_reason = $Test->find_TODO();
1718 my $todo_reason = $Test->find_TODO($pack):
1720 Like C<<todo()>> but only returns the value of C<<$TODO>> ignoring
1726 my( $self, $pack ) = @_;
1728 $pack = $pack || $self->caller(1) || $self->exported_to;
1729 return unless $pack;
1731 no strict 'refs'; ## no critic
1732 return ${ $pack . '::TODO' };
1737 my $in_todo = $Test->in_todo;
1739 Returns true if the test is currently inside a TODO block.
1746 local $Level = $Level + 1;
1747 return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
1752 $Test->todo_start();
1753 $Test->todo_start($message);
1755 This method allows you declare all subsequent tests as TODO tests, up until
1756 the C<todo_end> method has been called.
1758 The C<TODO:> and C<$TODO> syntax is generally pretty good about figuring out
1759 whether or not we're in a TODO test. However, often we find that this is not
1760 possible to determine (such as when we want to use C<$TODO> but
1761 the tests are being executed in other packages which can't be inferred
1764 Note that you can use this to nest "todo" tests
1766 $Test->todo_start('working on this');
1768 $Test->todo_start('working on that');
1773 This is generally not recommended, but large testing systems often have weird
1776 We've tried to make this also work with the TODO: syntax, but it's not
1777 guaranteed and its use is also discouraged:
1780 local $TODO = 'We have work to do!';
1781 $Test->todo_start('working on this');
1783 $Test->todo_start('working on that');
1789 Pick one style or another of "TODO" to be on the safe side.
1795 my $message = @_ ? shift : '';
1797 $self->{Start_Todo}++;
1798 if( $self->in_todo ) {
1799 push @{ $self->{Todo_Stack} } => $self->todo;
1801 $self->{Todo} = $message;
1810 Stops running tests as "TODO" tests. This method is fatal if called without a
1811 preceding C<todo_start> method call.
1818 if( !$self->{Start_Todo} ) {
1819 $self->croak('todo_end() called without todo_start()');
1822 $self->{Start_Todo}--;
1824 if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
1825 $self->{Todo} = pop @{ $self->{Todo_Stack} };
1828 delete $self->{Todo};
1836 my $package = $Test->caller;
1837 my($pack, $file, $line) = $Test->caller;
1838 my($pack, $file, $line) = $Test->caller($height);
1840 Like the normal caller(), except it reports according to your level().
1842 C<$height> will be added to the level().
1844 If caller() winds up off the top of the stack it report the highest context.
1848 sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
1849 my( $self, $height ) = @_;
1852 my $level = $self->level + $height + 1;
1855 @caller = CORE::caller( $level );
1858 return wantarray ? @caller : $caller[0];
1869 =item B<_sanity_check>
1871 $self->_sanity_check();
1873 Runs a bunch of end of test sanity checks to make sure reality came
1874 through ok. If anything is wrong it will die with a fairly friendly
1883 $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
1884 $self->_whoa( !$self->{Have_Plan} and $self->{Curr_Test},
1885 'Somehow your tests ran without a plan!' );
1886 $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
1887 'Somehow you got a different number of results than tests ran!' );
1894 $self->_whoa($check, $description);
1896 A sanity check, similar to assert(). If the $check is true, something
1897 has gone horribly wrong. It will die with the given $description and
1898 a note to contact the author.
1903 my( $self, $check, $desc ) = @_;
1905 local $Level = $Level + 1;
1906 $self->croak(<<"WHOA");
1908 This should never happen! Please contact the author immediately!
1917 _my_exit($exit_num);
1919 Perl seems to have some trouble with exiting inside an END block. 5.005_03
1920 and 5.6.1 both seem to do odd things. Instead, this function edits $?
1921 directly. It should ONLY be called from inside an END block. It
1922 doesn't actually exit, that's your job.
1927 $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
1941 my $real_exit_code = $?;
1942 $self->_sanity_check();
1944 # Don't bother with an ending if this is a forked copy. Only the parent
1945 # should do the ending.
1946 if( $self->{Original_Pid} != $$ ) {
1950 # Exit if plan() was never called. This is so "require Test::Simple"
1952 if( !$self->{Have_Plan} ) {
1956 # Don't do an ending if we bailed out.
1957 if( $self->{Bailed_Out} ) {
1961 # Figure out if we passed or failed and print helpful messages.
1962 my $test_results = $self->{Test_Results};
1963 if(@$test_results) {
1964 # The plan? We have no plan.
1965 if( $self->{No_Plan} ) {
1966 $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
1967 $self->{Expected_Tests} = $self->{Curr_Test};
1970 # Auto-extended arrays and elements which aren't explicitly
1971 # filled in with a shared reference will puke under 5.8.0
1972 # ithreads. So we have to fill them in by hand. :(
1973 my $empty_result = &share( {} );
1974 for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
1975 $test_results->[$idx] = $empty_result
1976 unless defined $test_results->[$idx];
1979 my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
1981 my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
1983 if( $num_extra != 0 ) {
1984 my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1985 $self->diag(<<"FAIL");
1986 Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}.
1991 my $num_tests = $self->{Curr_Test};
1992 my $s = $num_failed == 1 ? '' : 's';
1994 my $qualifier = $num_extra == 0 ? '' : ' run';
1996 $self->diag(<<"FAIL");
1997 Looks like you failed $num_failed test$s of $num_tests$qualifier.
2001 if($real_exit_code) {
2002 $self->diag(<<"FAIL");
2003 Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
2006 _my_exit($real_exit_code) && return;
2011 $exit_code = $num_failed <= 254 ? $num_failed : 254;
2013 elsif( $num_extra != 0 ) {
2020 _my_exit($exit_code) && return;
2022 elsif( $self->{Skip_All} ) {
2023 _my_exit(0) && return;
2025 elsif($real_exit_code) {
2026 $self->diag(<<"FAIL");
2027 Looks like your test exited with $real_exit_code before it could output anything.
2029 _my_exit($real_exit_code) && return;
2032 $self->diag("No tests run!\n");
2033 _my_exit(255) && return;
2036 $self->_whoa( 1, "We fell off the end of _ending()" );
2040 $Test->_ending if defined $Test and !$Test->no_ending;
2045 If all your tests passed, Test::Builder will exit with zero (which is
2046 normal). If anything failed it will exit with how many failed. If
2047 you run less (or more) tests than you planned, the missing (or extras)
2048 will be considered failures. If no tests were ever run Test::Builder
2049 will throw a warning and exit with 255. If the test died, even after
2050 having successfully completed all its tests, it will still be
2051 considered a failure and will exit with 255.
2053 So the exit codes are...
2055 0 all tests successful
2056 255 test died or all passed but wrong # of tests run
2057 any other number how many failed (including missing or extras)
2059 If you fail more than 254 tests, it will be reported as 254.
2064 In perl 5.8.1 and later, Test::Builder is thread-safe. The test
2065 number is shared amongst all threads. This means if one thread sets
2066 the test number using current_test() they will all be effected.
2068 While versions earlier than 5.8.1 had threads they contain too many
2071 Test::Builder is only thread-aware if threads.pm is loaded I<before>
2076 CPAN can provide the best examples. Test::Simple, Test::More,
2077 Test::Exception and Test::Differences all use Test::Builder.
2081 Test::Simple, Test::More, Test::Harness
2085 Original code by chromatic, maintained by Michael G Schwern
2086 E<lt>schwern@pobox.comE<gt>
2090 Copyright 2002-2008 by chromatic E<lt>chromatic@wgz.orgE<gt> and
2091 Michael G Schwern E<lt>schwern@pobox.comE<gt>.
2093 This program is free software; you can redistribute it and/or
2094 modify it under the same terms as Perl itself.
2096 See F<http://www.perl.com/perl/misc/Artistic.html>