5 # $^C was only introduced in 5.005-ish. We do this to prevent
6 # use of uninitialized value warnings in older perls.
10 use vars qw($VERSION);
12 $VERSION = eval $VERSION; # make the alpha version come out as a number
14 # Make Test::Builder thread-safe for ithreads.
17 # Load threads::shared when threads are turned on
18 if( $] >= 5.008 && $Config{useithreads} && $INC{'threads.pm'}) {
19 require threads::shared;
21 # Hack around YET ANOTHER threads::shared bug. It would
22 # occassionally forget the contents of the variable when sharing it.
23 # So we first copy the data, then share, then put our copy back.
24 *share = sub (\[$@%]) {
28 if( $type eq 'HASH' ) {
31 elsif( $type eq 'ARRAY' ) {
34 elsif( $type eq 'SCALAR' ) {
38 die "Unknown type: ".$type;
41 $_[0] = &threads::shared::share($_[0]);
43 if( $type eq 'HASH' ) {
46 elsif( $type eq 'ARRAY' ) {
49 elsif( $type eq 'SCALAR' ) {
53 die "Unknown type: ".$type;
59 # 5.8.0's threads::shared is busted when threads are off.
62 *share = sub { return $_[0] };
70 Test::Builder - Backend for building test libraries
74 package My::Test::Module;
80 my $Test = Test::Builder->new;
81 $Test->output('my_logfile');
87 $Test->exported_to($pack);
90 $self->export_to_level(1, $self, 'ok');
94 my($test, $name) = @_;
96 $Test->ok($test, $name);
102 Test::Simple and Test::More have proven to be popular testing modules,
103 but they're not always flexible enough. Test::Builder provides the a
104 building block upon which to write your own test libraries I<which can
113 my $Test = Test::Builder->new;
115 Returns a Test::Builder object representing the current state of the
118 Since you only run one test per program C<new> always returns the same
119 Test::Builder object. No matter how many times you call new(), you're
120 getting the same object. This is called a singleton. This is done so that
121 multiple modules share such global information as the test counter and
122 where test output is going.
124 If you want a completely new Test::Builder object different from the
125 singleton, use C<create>.
129 my $Test = Test::Builder->new;
132 $Test ||= $class->create;
139 my $Test = Test::Builder->create;
141 Ok, so there can be more than one Test::Builder object and this is how
142 you get it. You might use this instead of C<new()> if you're testing
143 a Test::Builder based module, but otherwise you probably want C<new>.
145 B<NOTE>: the implementation is not complete. C<level>, for example, is
146 still shared amongst B<all> Test::Builder objects, even ones created using
147 this method. Also, the method name may change in the future.
154 my $self = bless {}, $class;
164 Reinitializes the Test::Builder singleton to its original state.
165 Mostly useful for tests run in persistent environments where the same
166 test might be run multiple times in the same process.
175 # We leave this a global because it has to be localized and localizing
176 # hash keys is just asking for pain. Also, it was documented.
179 $self->{Test_Died} = 0;
180 $self->{Have_Plan} = 0;
181 $self->{No_Plan} = 0;
182 $self->{Original_Pid} = $$;
184 share($self->{Curr_Test});
185 $self->{Curr_Test} = 0;
186 $self->{Test_Results} = &share([]);
188 $self->{Exported_To} = undef;
189 $self->{Expected_Tests} = 0;
191 $self->{Skip_All} = 0;
193 $self->{Use_Nums} = 1;
195 $self->{No_Header} = 0;
196 $self->{No_Ending} = 0;
198 $self->_dup_stdhandles unless $^C;
205 =head2 Setting up tests
207 These methods are for setting up tests and declaring how many there
208 are. You usually only want to call one of these methods.
214 my $pack = $Test->exported_to;
215 $Test->exported_to($pack);
217 Tells Test::Builder what package you exported your functions to.
218 This is important for getting TODO tests right.
223 my($self, $pack) = @_;
225 if( defined $pack ) {
226 $self->{Exported_To} = $pack;
228 return $self->{Exported_To};
233 $Test->plan('no_plan');
234 $Test->plan( skip_all => $reason );
235 $Test->plan( tests => $num_tests );
237 A convenient way to set up your tests. Call this and Test::Builder
238 will print the appropriate headers and take the appropriate actions.
240 If you call plan(), don't call any of the other methods below.
245 my($self, $cmd, $arg) = @_;
249 if( $self->{Have_Plan} ) {
250 die sprintf "You tried to plan twice! Second plan at %s line %d\n",
251 ($self->caller)[1,2];
254 if( $cmd eq 'no_plan' ) {
257 elsif( $cmd eq 'skip_all' ) {
258 return $self->skip_all($arg);
260 elsif( $cmd eq 'tests' ) {
262 return $self->expected_tests($arg);
264 elsif( !defined $arg ) {
265 die "Got an undefined number of tests. Looks like you tried to ".
266 "say how many tests you plan to run but made a mistake.\n";
269 die "You said to run 0 tests! You've got to run something.\n";
274 my @args = grep { defined } ($cmd, $arg);
275 Carp::croak("plan() doesn't understand @args");
281 =item B<expected_tests>
283 my $max = $Test->expected_tests;
284 $Test->expected_tests($max);
286 Gets/sets the # of tests we expect this test to run and prints out
287 the appropriate headers.
296 die "Number of tests must be a postive integer. You gave it '$max'.\n"
297 unless $max =~ /^\+?\d+$/ and $max > 0;
299 $self->{Expected_Tests} = $max;
300 $self->{Have_Plan} = 1;
302 $self->_print("1..$max\n") unless $self->no_header;
304 return $self->{Expected_Tests};
312 Declares that this test will run an indeterminate # of tests.
319 $self->{No_Plan} = 1;
320 $self->{Have_Plan} = 1;
325 $plan = $Test->has_plan
327 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).
334 return($self->{Expected_Tests}) if $self->{Expected_Tests};
335 return('no_plan') if $self->{No_Plan};
343 $Test->skip_all($reason);
345 Skips all the tests, using the given $reason. Exits immediately with 0.
350 my($self, $reason) = @_;
353 $out .= " # Skip $reason" if $reason;
356 $self->{Skip_All} = 1;
358 $self->_print($out) unless $self->no_header;
366 These actually run the tests, analogous to the functions in
369 $name is always optional.
375 $Test->ok($test, $name);
377 Your basic test. Pass if $test is true, fail if $test is false. Just
378 like Test::Simple's ok().
383 my($self, $test, $name) = @_;
385 # $test might contain an object which we don't want to accidentally
386 # store, so we turn it into a boolean.
387 $test = $test ? 1 : 0;
389 unless( $self->{Have_Plan} ) {
391 Carp::croak("You tried to run a test without a plan! Gotta have a plan.");
394 lock $self->{Curr_Test};
395 $self->{Curr_Test}++;
397 # In case $name is a string overloaded object, force it to stringify.
398 $self->_unoverload_str(\$name);
400 $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
401 You named your test '$name'. You shouldn't use numbers for your test names.
405 my($pack, $file, $line) = $self->caller;
407 my $todo = $self->todo($pack);
408 $self->_unoverload_str(\$todo);
411 my $result = &share({});
415 @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
418 @$result{ 'ok', 'actual_ok' } = ( 1, $test );
422 $out .= " $self->{Curr_Test}" if $self->use_numbers;
424 if( defined $name ) {
425 $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
427 $result->{name} = $name;
430 $result->{name} = '';
434 $out .= " # TODO $todo";
435 $result->{reason} = $todo;
436 $result->{type} = 'todo';
439 $result->{reason} = '';
440 $result->{type} = '';
443 $self->{Test_Results}[$self->{Curr_Test}-1] = $result;
449 my $msg = $todo ? "Failed (TODO)" : "Failed";
450 $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
452 if( defined $name ) {
453 $self->diag(qq[ $msg test '$name'\n]);
454 $self->diag(qq[ in $file at line $line.\n]);
457 $self->diag(qq[ $msg test in $file at line $line.\n]);
461 return $test ? 1 : 0;
471 eval { require overload } || return;
473 foreach my $thing (@_) {
475 if( _is_object($$thing) ) {
476 if( my $string_meth = overload::Method($$thing, $type) ) {
477 $$thing = $$thing->$string_meth();
488 return eval { ref $thing && $thing->isa('UNIVERSAL') } ? 1 : 0;
492 sub _unoverload_str {
495 $self->_unoverload(q[""], @_);
498 sub _unoverload_num {
501 $self->_unoverload('0+', @_);
504 next unless $self->_is_dualvar($$val);
510 # This is a hack to detect a dualvar such as $!
512 my($self, $val) = @_;
516 return 1 if $numval != 0 and $numval ne $val;
523 $Test->is_eq($got, $expected, $name);
525 Like Test::More's is(). Checks if $got eq $expected. This is the
530 $Test->is_num($got, $expected, $name);
532 Like Test::More's is(). Checks if $got == $expected. This is the
538 my($self, $got, $expect, $name) = @_;
539 local $Level = $Level + 1;
541 $self->_unoverload_str(\$got, \$expect);
543 if( !defined $got || !defined $expect ) {
544 # undef only matches undef and nothing else
545 my $test = !defined $got && !defined $expect;
547 $self->ok($test, $name);
548 $self->_is_diag($got, 'eq', $expect) unless $test;
552 return $self->cmp_ok($got, 'eq', $expect, $name);
556 my($self, $got, $expect, $name) = @_;
557 local $Level = $Level + 1;
559 $self->_unoverload_num(\$got, \$expect);
561 if( !defined $got || !defined $expect ) {
562 # undef only matches undef and nothing else
563 my $test = !defined $got && !defined $expect;
565 $self->ok($test, $name);
566 $self->_is_diag($got, '==', $expect) unless $test;
570 return $self->cmp_ok($got, '==', $expect, $name);
574 my($self, $got, $type, $expect) = @_;
576 foreach my $val (\$got, \$expect) {
577 if( defined $$val ) {
578 if( $type eq 'eq' ) {
579 # quote and force string context
583 # force numeric context
584 $self->_unoverload_num($val);
592 return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
601 $Test->isnt_eq($got, $dont_expect, $name);
603 Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
608 $Test->is_num($got, $dont_expect, $name);
610 Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
616 my($self, $got, $dont_expect, $name) = @_;
617 local $Level = $Level + 1;
619 if( !defined $got || !defined $dont_expect ) {
620 # undef only matches undef and nothing else
621 my $test = defined $got || defined $dont_expect;
623 $self->ok($test, $name);
624 $self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
628 return $self->cmp_ok($got, 'ne', $dont_expect, $name);
632 my($self, $got, $dont_expect, $name) = @_;
633 local $Level = $Level + 1;
635 if( !defined $got || !defined $dont_expect ) {
636 # undef only matches undef and nothing else
637 my $test = defined $got || defined $dont_expect;
639 $self->ok($test, $name);
640 $self->_cmp_diag($got, '!=', $dont_expect) unless $test;
644 return $self->cmp_ok($got, '!=', $dont_expect, $name);
650 $Test->like($this, qr/$regex/, $name);
651 $Test->like($this, '/$regex/', $name);
653 Like Test::More's like(). Checks if $this matches the given $regex.
655 You'll want to avoid qr// if you want your tests to work before 5.005.
659 $Test->unlike($this, qr/$regex/, $name);
660 $Test->unlike($this, '/$regex/', $name);
662 Like Test::More's unlike(). Checks if $this B<does not match> the
668 my($self, $this, $regex, $name) = @_;
670 local $Level = $Level + 1;
671 $self->_regex_ok($this, $regex, '=~', $name);
675 my($self, $this, $regex, $name) = @_;
677 local $Level = $Level + 1;
678 $self->_regex_ok($this, $regex, '!~', $name);
683 $Test->maybe_regex(qr/$regex/);
684 $Test->maybe_regex('/$regex/');
686 Convenience method for building testing functions that take regular
687 expressions as arguments, but need to work before perl 5.005.
689 Takes a quoted regular expression produced by qr//, or a string
690 representing a regular expression.
692 Returns a Perl value which may be used instead of the corresponding
693 regular expression, or undef if it's argument is not recognised.
695 For example, a version of like(), sans the useful diagnostic messages,
699 my ($self, $this, $regex, $name) = @_;
700 my $usable_regex = $self->maybe_regex($regex);
701 die "expecting regex, found '$regex'\n"
702 unless $usable_regex;
703 $self->ok($this =~ m/$usable_regex/, $name);
710 my ($self, $regex) = @_;
711 my $usable_regex = undef;
713 return $usable_regex unless defined $regex;
718 if( ref $regex eq 'Regexp' ) {
719 $usable_regex = $regex;
721 # Check for '/foo/' or 'm,foo,'
722 elsif( ($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
723 (undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
726 $usable_regex = length $opts ? "(?$opts)$re" : $re;
729 return $usable_regex;
733 my($self, $this, $regex, $cmp, $name) = @_;
736 my $usable_regex = $self->maybe_regex($regex);
737 unless (defined $usable_regex) {
738 $ok = $self->ok( 0, $name );
739 $self->diag(" '$regex' doesn't look much like a regex to me.");
745 my $code = $self->_caller_context;
749 # Yes, it has to look like this or 5.4.5 won't see the #line directive.
750 # Don't ask me, man, I just work here.
752 $code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
754 $test = !$test if $cmp eq '!~';
756 local $Level = $Level + 1;
757 $ok = $self->ok( $test, $name );
761 $this = defined $this ? "'$this'" : 'undef';
762 my $match = $cmp eq '=~' ? "doesn't match" : "matches";
763 $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
775 $Test->cmp_ok($this, $type, $that, $name);
777 Works just like Test::More's cmp_ok().
779 $Test->cmp_ok($big_num, '!=', $other_big_num);
784 my %numeric_cmps = map { ($_, 1) }
785 ("<", "<=", ">", ">=", "==", "!=", "<=>");
788 my($self, $got, $type, $expect, $name) = @_;
790 # Treat overloaded objects as numbers if we're asked to do a
791 # numeric comparison.
792 my $unoverload = $numeric_cmps{$type} ? '_unoverload_num'
795 $self->$unoverload(\$got, \$expect);
800 local($@,$!); # don't interfere with $@
801 # eval() sometimes resets $!
803 my $code = $self->_caller_context;
805 # Yes, it has to look like this or 5.4.5 won't see the #line directive.
806 # Don't ask me, man, I just work here.
808 $code" . "\$got $type \$expect;";
811 local $Level = $Level + 1;
812 my $ok = $self->ok($test, $name);
815 if( $type =~ /^(eq|==)$/ ) {
816 $self->_is_diag($got, $type, $expect);
819 $self->_cmp_diag($got, $type, $expect);
826 my($self, $got, $type, $expect) = @_;
828 $got = defined $got ? "'$got'" : 'undef';
829 $expect = defined $expect ? "'$expect'" : 'undef';
830 return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
838 sub _caller_context {
841 my($pack, $file, $line) = $self->caller(1);
844 $code .= "#line $line $file\n" if defined $file and defined $line;
852 $Test->BAIL_OUT($reason);
854 Indicates to the Test::Harness that things are going so badly all
855 testing should terminate. This includes running any additional test
858 It will exit with 255.
863 my($self, $reason) = @_;
865 $self->{Bailed_Out} = 1;
866 $self->_print("Bail out! $reason");
871 BAIL_OUT() used to be BAILOUT()
873 *BAILOUT = \&BAIL_OUT;
881 Skips the current test, reporting $why.
886 my($self, $why) = @_;
888 $self->_unoverload_str(\$why);
890 unless( $self->{Have_Plan} ) {
892 Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
895 lock($self->{Curr_Test});
896 $self->{Curr_Test}++;
898 $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
907 $out .= " $self->{Curr_Test}" if $self->use_numbers;
909 $out .= " $why" if length $why;
921 $Test->todo_skip($why);
923 Like skip(), only it will declare the test as failing and TODO. Similar
926 print "not ok $tnum # TODO $why\n";
931 my($self, $why) = @_;
934 unless( $self->{Have_Plan} ) {
936 Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
939 lock($self->{Curr_Test});
940 $self->{Curr_Test}++;
942 $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
951 $out .= " $self->{Curr_Test}" if $self->use_numbers;
952 $out .= " # TODO & SKIP $why\n";
960 =begin _unimplemented
965 $Test->skip_rest($reason);
967 Like skip(), only it skips all the rest of the tests you plan to run
968 and terminates the test.
970 If you're running under no_plan, it skips once and terminates the
984 $Test->level($how_high);
986 How far up the call stack should $Test look when reporting where the
991 Setting $Test::Builder::Level overrides. This is typically useful
995 local $Test::Builder::Level = 2;
1002 my($self, $level) = @_;
1004 if( defined $level ) {
1011 =item B<use_numbers>
1013 $Test->use_numbers($on_or_off);
1015 Whether or not the test should output numbers. That is, this if true:
1027 Most useful when you can't depend on the test output order, such as
1028 when threads or forking is involved.
1030 Test::Harness will accept either, but avoid mixing the two styles.
1037 my($self, $use_nums) = @_;
1039 if( defined $use_nums ) {
1040 $self->{Use_Nums} = $use_nums;
1042 return $self->{Use_Nums};
1048 $Test->no_diag($no_diag);
1050 If set true no diagnostics will be printed. This includes calls to
1055 $Test->no_ending($no_ending);
1057 Normally, Test::Builder does some extra diagnostics when the test
1058 ends. It also changes the exit code as described below.
1060 If this is true, none of that will be done.
1064 $Test->no_header($no_header);
1066 If set to true, no "1..N" header will be printed.
1070 foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
1071 my $method = lc $attribute;
1074 my($self, $no) = @_;
1077 $self->{$attribute} = $no;
1079 return $self->{$attribute};
1083 *{__PACKAGE__.'::'.$method} = $code;
1091 Controlling where the test output goes.
1093 It's ok for your test to change where STDOUT and STDERR point to,
1094 Test::Builder's default output settings will not be affected.
1102 Prints out the given @msgs. Like C<print>, arguments are simply
1105 Normally, it uses the failure_output() handle, but if this is for a
1106 TODO test, the todo_output() handle is used.
1108 Output will be indented and marked with a # so as not to interfere
1109 with test output. A newline will be put on the end if there isn't one
1112 We encourage using this rather than calling print directly.
1114 Returns false. Why? Because diag() is often used in conjunction with
1115 a failing test (C<ok() || diag()>) it "passes through" the failure.
1117 return ok(...) || diag(...);
1120 Mark Fowler <mark@twoshortplanks.com>
1125 my($self, @msgs) = @_;
1127 return if $self->no_diag;
1128 return unless @msgs;
1130 # Prevent printing headers when compiling (i.e. -c)
1133 # Smash args together like print does.
1134 # Convert undef to 'undef' so its readable.
1135 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1137 # Escape each line with a #.
1140 # Stick a newline on the end if it needs it.
1141 $msg .= "\n" unless $msg =~ /\n\Z/;
1143 local $Level = $Level + 1;
1144 $self->_print_diag($msg);
1153 $Test->_print(@msgs);
1155 Prints to the output() filehandle.
1162 my($self, @msgs) = @_;
1164 # Prevent printing headers when only compiling. Mostly for when
1165 # tests are deparsed with B::Deparse
1168 my $msg = join '', @msgs;
1170 local($\, $", $,) = (undef, ' ', '');
1171 my $fh = $self->output;
1173 # Escape each line after the first with a # so we don't
1174 # confuse Test::Harness.
1175 $msg =~ s/\n(.)/\n# $1/sg;
1177 # Stick a newline on the end if it needs it.
1178 $msg .= "\n" unless $msg =~ /\n\Z/;
1184 =item B<_print_diag>
1186 $Test->_print_diag(@msg);
1188 Like _print, but prints to the current diagnostic filehandle.
1195 local($\, $", $,) = (undef, ' ', '');
1196 my $fh = $self->todo ? $self->todo_output : $self->failure_output;
1203 $Test->output($file);
1205 Where normal "ok/not ok" test output should go.
1209 =item B<failure_output>
1211 $Test->failure_output($fh);
1212 $Test->failure_output($file);
1214 Where diagnostic output on test failures and diag() should go.
1218 =item B<todo_output>
1220 $Test->todo_output($fh);
1221 $Test->todo_output($file);
1223 Where diagnostics about todo test failures and diag() should go.
1230 my($self, $fh) = @_;
1233 $self->{Out_FH} = _new_fh($fh);
1235 return $self->{Out_FH};
1238 sub failure_output {
1239 my($self, $fh) = @_;
1242 $self->{Fail_FH} = _new_fh($fh);
1244 return $self->{Fail_FH};
1248 my($self, $fh) = @_;
1251 $self->{Todo_FH} = _new_fh($fh);
1253 return $self->{Todo_FH};
1258 my($file_or_fh) = shift;
1261 if( _is_fh($file_or_fh) ) {
1265 $fh = do { local *FH };
1266 open $fh, ">$file_or_fh" or
1267 die "Can't open test output log $file_or_fh: $!";
1276 my $maybe_fh = shift;
1277 return 0 unless defined $maybe_fh;
1279 return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
1281 return UNIVERSAL::isa($maybe_fh, 'GLOB') ||
1282 UNIVERSAL::isa($maybe_fh, 'IO::Handle') ||
1284 # 5.5.4's tied() and can() doesn't like getting undef
1285 UNIVERSAL::can((tied($maybe_fh) || ''), 'TIEHANDLE');
1291 my $old_fh = select $fh;
1297 sub _dup_stdhandles {
1300 $self->_open_testhandles;
1302 # Set everything to unbuffered else plain prints to STDOUT will
1303 # come out in the wrong order from our own prints.
1304 _autoflush(\*TESTOUT);
1305 _autoflush(\*STDOUT);
1306 _autoflush(\*TESTERR);
1307 _autoflush(\*STDERR);
1309 $self->output(\*TESTOUT);
1310 $self->failure_output(\*TESTERR);
1311 $self->todo_output(\*TESTOUT);
1315 my $Opened_Testhandles = 0;
1316 sub _open_testhandles {
1317 return if $Opened_Testhandles;
1318 # We dup STDOUT and STDERR so people can change them in their
1319 # test suites while still getting normal test output.
1320 open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
1321 open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
1322 $Opened_Testhandles = 1;
1329 =head2 Test Status and Info
1333 =item B<current_test>
1335 my $curr_test = $Test->current_test;
1336 $Test->current_test($num);
1338 Gets/sets the current test number we're on. You usually shouldn't
1341 If set forward, the details of the missing tests are filled in as 'unknown'.
1342 if set backward, the details of the intervening tests are deleted. You
1343 can erase history if you really want to.
1348 my($self, $num) = @_;
1350 lock($self->{Curr_Test});
1351 if( defined $num ) {
1352 unless( $self->{Have_Plan} ) {
1354 Carp::croak("Can't change the current test number without a plan!");
1357 $self->{Curr_Test} = $num;
1359 # If the test counter is being pushed forward fill in the details.
1360 my $test_results = $self->{Test_Results};
1361 if( $num > @$test_results ) {
1362 my $start = @$test_results ? @$test_results : 0;
1363 for ($start..$num-1) {
1364 $test_results->[$_] = &share({
1367 reason => 'incrementing test number',
1373 # If backward, wipe history. Its their funeral.
1374 elsif( $num < @$test_results ) {
1375 $#{$test_results} = $num - 1;
1378 return $self->{Curr_Test};
1384 my @tests = $Test->summary;
1386 A simple summary of the tests so far. True for pass, false for fail.
1387 This is a logical pass/fail, so todos are passes.
1389 Of course, test #1 is $tests[0], etc...
1396 return map { $_->{'ok'} } @{ $self->{Test_Results} };
1401 my @tests = $Test->details;
1403 Like summary(), but with a lot more detail.
1405 $tests[$test_num - 1] =
1406 { 'ok' => is the test considered a pass?
1407 actual_ok => did it literally say 'ok'?
1408 name => name of the test (if any)
1409 type => type of test (if any, see below).
1410 reason => reason for the above (if any)
1413 'ok' is true if Test::Harness will consider the test to be a pass.
1415 'actual_ok' is a reflection of whether or not the test literally
1416 printed 'ok' or 'not ok'. This is for examining the result of 'todo'
1419 'name' is the name of the test.
1421 'type' indicates if it was a special test. Normal tests have a type
1422 of ''. Type can be one of the following:
1426 todo_skip see todo_skip()
1429 Sometimes the Test::Builder test counter is incremented without it
1430 printing any test output, for example, when current_test() is changed.
1431 In these cases, Test::Builder doesn't know the result of the test, so
1432 it's type is 'unkown'. These details for these tests are filled in.
1433 They are considered ok, but the name and actual_ok is left undef.
1435 For example "not ok 23 - hole count # TODO insufficient donuts" would
1436 result in this structure:
1438 $tests[22] = # 23 - 1, since arrays start from 0.
1439 { ok => 1, # logically, the test passed since it's todo
1440 actual_ok => 0, # in absolute terms, it failed
1441 name => 'hole count',
1443 reason => 'insufficient donuts'
1450 return @{ $self->{Test_Results} };
1455 my $todo_reason = $Test->todo;
1456 my $todo_reason = $Test->todo($pack);
1458 todo() looks for a $TODO variable in your tests. If set, all tests
1459 will be considered 'todo' (see Test::More and Test::Harness for
1460 details). Returns the reason (ie. the value of $TODO) if running as
1461 todo tests, false otherwise.
1463 todo() is about finding the right package to look for $TODO in. It
1464 uses the exported_to() package to find it. If that's not set, it's
1465 pretty good at guessing the right package to look at based on $Level.
1467 Sometimes there is some confusion about where todo() should be looking
1468 for the $TODO variable. If you want to be sure, tell it explicitly
1474 my($self, $pack) = @_;
1476 $pack = $pack || $self->exported_to || $self->caller($Level);
1477 return 0 unless $pack;
1480 return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
1486 my $package = $Test->caller;
1487 my($pack, $file, $line) = $Test->caller;
1488 my($pack, $file, $line) = $Test->caller($height);
1490 Like the normal caller(), except it reports according to your level().
1495 my($self, $height) = @_;
1498 my @caller = CORE::caller($self->level + $height + 1);
1499 return wantarray ? @caller : $caller[0];
1510 =item B<_sanity_check>
1512 $self->_sanity_check();
1514 Runs a bunch of end of test sanity checks to make sure reality came
1515 through ok. If anything is wrong it will die with a fairly friendly
1524 _whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!');
1525 _whoa(!$self->{Have_Plan} and $self->{Curr_Test},
1526 'Somehow your tests ran without a plan!');
1527 _whoa($self->{Curr_Test} != @{ $self->{Test_Results} },
1528 'Somehow you got a different number of results than tests ran!');
1533 _whoa($check, $description);
1535 A sanity check, similar to assert(). If the $check is true, something
1536 has gone horribly wrong. It will die with the given $description and
1537 a note to contact the author.
1542 my($check, $desc) = @_;
1546 This should never happen! Please contact the author immediately!
1553 _my_exit($exit_num);
1555 Perl seems to have some trouble with exiting inside an END block. 5.005_03
1556 and 5.6.1 both seem to do odd things. Instead, this function edits $?
1557 directly. It should ONLY be called from inside an END block. It
1558 doesn't actually exit, that's your job.
1575 $SIG{__DIE__} = sub {
1576 # We don't want to muck with death in an eval, but $^S isn't
1577 # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
1578 # with it. Instead, we use caller. This also means it runs under
1581 for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) {
1582 $in_eval = 1 if $sub =~ /^\(eval\)/;
1584 $Test->{Test_Died} = 1 unless $in_eval;
1590 $self->_sanity_check();
1592 # Don't bother with an ending if this is a forked copy. Only the parent
1593 # should do the ending.
1594 # Exit if plan() was never called. This is so "require Test::Simple"
1596 # Don't do an ending if we bailed out.
1597 if( ($self->{Original_Pid} != $$) or
1598 (!$self->{Have_Plan} && !$self->{Test_Died}) or
1606 # Figure out if we passed or failed and print helpful messages.
1607 my $test_results = $self->{Test_Results};
1608 if( @$test_results ) {
1609 # The plan? We have no plan.
1610 if( $self->{No_Plan} ) {
1611 $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
1612 $self->{Expected_Tests} = $self->{Curr_Test};
1615 # Auto-extended arrays and elements which aren't explicitly
1616 # filled in with a shared reference will puke under 5.8.0
1617 # ithreads. So we have to fill them in by hand. :(
1618 my $empty_result = &share({});
1619 for my $idx ( 0..$self->{Expected_Tests}-1 ) {
1620 $test_results->[$idx] = $empty_result
1621 unless defined $test_results->[$idx];
1624 my $num_failed = grep !$_->{'ok'},
1625 @{$test_results}[0..$self->{Curr_Test}-1];
1627 my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
1629 if( $num_extra < 0 ) {
1630 my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1631 $self->diag(<<"FAIL");
1632 Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}.
1635 elsif( $num_extra > 0 ) {
1636 my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1637 $self->diag(<<"FAIL");
1638 Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra.
1642 if ( $num_failed ) {
1643 my $num_tests = $self->{Curr_Test};
1644 my $s = $num_failed == 1 ? '' : 's';
1646 my $qualifier = $num_extra == 0 ? '' : ' run';
1648 $self->diag(<<"FAIL");
1649 Looks like you failed $num_failed test$s of $num_tests$qualifier.
1653 if( $self->{Test_Died} ) {
1654 $self->diag(<<"FAIL");
1655 Looks like your test died just after $self->{Curr_Test}.
1658 _my_exit( 255 ) && return;
1663 $exit_code = $num_failed <= 254 ? $num_failed : 254;
1665 elsif( $num_extra != 0 ) {
1672 _my_exit( $exit_code ) && return;
1674 elsif ( $self->{Skip_All} ) {
1675 _my_exit( 0 ) && return;
1677 elsif ( $self->{Test_Died} ) {
1678 $self->diag(<<'FAIL');
1679 Looks like your test died before it could output anything.
1681 _my_exit( 255 ) && return;
1684 $self->diag("No tests run!\n");
1685 _my_exit( 255 ) && return;
1690 $Test->_ending if defined $Test and !$Test->no_ending;
1695 If all your tests passed, Test::Builder will exit with zero (which is
1696 normal). If anything failed it will exit with how many failed. If
1697 you run less (or more) tests than you planned, the missing (or extras)
1698 will be considered failures. If no tests were ever run Test::Builder
1699 will throw a warning and exit with 255. If the test died, even after
1700 having successfully completed all its tests, it will still be
1701 considered a failure and will exit with 255.
1703 So the exit codes are...
1705 0 all tests successful
1706 255 test died or all passed but wrong # of tests run
1707 any other number how many failed (including missing or extras)
1709 If you fail more than 254 tests, it will be reported as 254.
1714 In perl 5.8.0 and later, Test::Builder is thread-safe. The test
1715 number is shared amongst all threads. This means if one thread sets
1716 the test number using current_test() they will all be effected.
1718 Test::Builder is only thread-aware if threads.pm is loaded I<before>
1723 CPAN can provide the best examples. Test::Simple, Test::More,
1724 Test::Exception and Test::Differences all use Test::Builder.
1728 Test::Simple, Test::More, Test::Harness
1732 Original code by chromatic, maintained by Michael G Schwern
1733 E<lt>schwern@pobox.comE<gt>
1737 Copyright 2002, 2004 by chromatic E<lt>chromatic@wgz.orgE<gt> and
1738 Michael G Schwern E<lt>schwern@pobox.comE<gt>.
1740 This program is free software; you can redistribute it and/or
1741 modify it under the same terms as Perl itself.
1743 See F<http://www.perl.com/perl/misc/Artistic.html>