7 our $VERSION = '1.302067';
11 require Test::Builder::IO::Scalar;
15 use Scalar::Util qw/blessed reftype weaken/;
17 use Test2::Util qw/USE_THREADS try get_tid/;
18 use Test2::API qw/context release/;
19 # Make Test::Builder thread-safe for ithreads.
21 warn "Test::Builder was loaded after Test2 initialization, this is not recommended."
22 if Test2::API::test2_init_done() || Test2::API::test2_load_done();
26 require Test2::IPC::Driver::Files;
27 Test2::IPC::Driver::Files->import;
28 Test2::API::test2_ipc_enable_polling();
29 Test2::API::test2_no_wait(1);
30 Test2::API::test2_ipc_enable_shm();
34 use Test2::Event::Subtest;
35 use Test2::Hub::Subtest;
37 use Test::Builder::Formatter;
38 use Test::Builder::TodoDiag;
41 our $Test = $ENV{TB_NO_EARLY_INIT} ? undef : Test::Builder->new;
45 my $hub = $self->{Stack}->top;
47 # Take a reference to the hash key, we do this to avoid closing over $self
48 # which is the singleton. We use a reference because the value could change
50 my $epkgr = \$self->{Exported_To};
52 #$hub->add_context_aquire(sub {$_[0]->{level} += $Level - 1});
54 $hub->pre_filter(sub {
55 my ($active_hub, $e) = @_;
58 my $cpkg = $e->{trace} ? $e->{trace}->{frame}->[0] : undef;
63 $todo = ${"$cpkg\::TODO"} if $cpkg;
64 $todo = ${"$epkg\::TODO"} if $epkg && !$todo;
66 return $e unless $todo;
68 # Turn a diag into a todo diag
69 return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag';
72 if ($e->isa('Test2::Event::Ok')) {
74 $e->set_effective_pass(1);
76 if (my $result = $e->get_meta(__PACKAGE__)) {
77 $result->{reason} ||= $todo;
78 $result->{type} ||= 'todo';
91 $Test = $class->create(singleton => 1);
94 # Non-TB tools normally expect 0 added to the level. $Level is normally 1. So
95 # we only want the level to change if $Level != 1.
96 # TB->ctx compensates for this later.
97 Test2::API::test2_add_callback_context_aquire(sub { $_[0]->{level} += $Level - 1 });
99 Test2::API::test2_add_callback_exit(sub { $Test->_ending(@_) });
101 Test2::API::test2_ipc()->set_no_fatal(1) if USE_THREADS;
110 my $self = bless {}, $class;
111 if ($params{singleton}) {
112 $self->{Stack} = Test2::API::test2_stack();
115 $self->{Stack} = Test2::API::Stack->new;
116 $self->{Stack}->new_hub(
117 formatter => Test::Builder::Formatter->new,
118 ipc => Test2::API::test2_ipc(),
121 $self->reset(%params);
122 $self->_add_ts_hooks;
130 # 1 for our frame, another for the -1 off of $Level in our hook at the top.
133 stack => $self->{Stack},
142 my $ctx = $self->ctx;
143 my $chub = $self->{Hub} || $ctx->hub;
146 my $parent = $chub->meta(__PACKAGE__, {})->{parent};
148 return undef unless $parent;
152 Stack => $self->{Stack},
158 my( $self, $name ) = @_;
160 $name ||= "Child of " . $self->name;
161 my $ctx = $self->ctx;
163 my $parent = $ctx->hub;
164 my $pmeta = $parent->meta(__PACKAGE__, {});
165 $self->croak("You already have a child named ($pmeta->{child}) running")
168 $pmeta->{child} = $name;
170 # Clear $TODO for the child.
171 my $orig_TODO = $self->find_TODO(undef, 1, undef);
175 my $hub = $ctx->stack->new_hub(
176 class => 'Test2::Hub::Subtest',
179 $hub->pre_filter(sub {
180 my ($active_hub, $e) = @_;
182 # Turn a diag into a todo diag
183 return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag';
186 }, inherit => 1) if $orig_TODO;
188 $hub->listen(sub { push @$subevents => $_[1] });
190 $hub->set_nested( $parent->isa('Test2::Hub::Subtest') ? $parent->nested + 1 : 1 );
192 my $meta = $hub->meta(__PACKAGE__, {});
193 $meta->{Name} = $name;
194 $meta->{TODO} = $orig_TODO;
195 $meta->{TODO_PKG} = $ctx->trace->package;
196 $meta->{parent} = $parent;
197 $meta->{Test_Results} = [];
198 $meta->{subevents} = $subevents;
199 $meta->{subtest_id} = $hub->id;
200 $meta->{subtest_buffered} = $parent->format ? 0 : 1;
202 $self->_add_ts_hooks;
205 return bless { Original_Pid => $$, Stack => $self->{Stack}, Hub => $hub }, blessed($self);
213 my $st_ctx = $self->ctx;
214 my $chub = $self->{Hub} || return $st_ctx->release;
216 my $meta = $chub->meta(__PACKAGE__, {});
217 if ($meta->{child}) {
218 $self->croak("Can't call finalize() with child ($meta->{child}) active");
221 local $? = 0; # don't fail if $subtests happened to set $? nonzero
223 $self->{Stack}->pop($chub);
225 $self->find_TODO($meta->{TODO_PKG}, 1, $meta->{TODO});
227 my $parent = $self->parent;
228 my $ctx = $parent->ctx;
229 my $trace = $ctx->trace;
230 delete $ctx->hub->meta(__PACKAGE__, {})->{child};
232 $chub->finalize($trace, 1)
238 my $plan = $chub->plan || 0;
239 my $count = $chub->count;
240 my $failed = $chub->failed;
241 my $passed = $chub->is_passing;
243 my $num_extra = $plan =~ m/\D/ ? 0 : $count - $plan;
244 if ($count && $num_extra != 0) {
245 my $s = $plan == 1 ? '' : 's';
246 $st_ctx->diag(<<"FAIL");
247 Looks like you planned $plan test$s but ran $count.
252 my $s = $failed == 1 ? '' : 's';
254 my $qualifier = $num_extra == 0 ? '' : ' run';
256 $st_ctx->diag(<<"FAIL");
257 Looks like you failed $failed test$s of $count$qualifier.
261 if (!$passed && !$failed && $count && !$num_extra) {
262 $st_ctx->diag(<<"FAIL");
263 All assertions inside the subtest passed, but errors were encountered.
269 unless ($chub->bailed_out) {
270 my $plan = $chub->plan;
271 if ( $plan && $plan eq 'SKIP' ) {
272 $parent->skip($chub->skip_reason, $meta->{Name});
274 elsif ( !$chub->count ) {
275 $parent->ok( 0, sprintf q[No tests run for subtest "%s"], $meta->{Name} );
278 $parent->{subevents} = $meta->{subevents};
279 $parent->{subtest_id} = $meta->{subtest_id};
280 $parent->{subtest_buffered} = $meta->{subtest_buffered};
281 $parent->ok( $chub->is_passing, $meta->{Name} );
286 return $chub->is_passing;
291 my ($name, $code, @args) = @_;
292 my $ctx = $self->ctx;
293 $ctx->throw("subtest()'s second argument must be a code ref")
294 unless $code && reftype($code) eq 'CODE';
296 $name ||= "Child of " . $self->name;
298 $ctx->note("Subtest: $name");
300 my $child = $self->child($name);
304 my ($ok, $err, $finished, $child_error);
305 T2_SUBTEST_WRAPPER: {
306 my $ctx = $self->ctx;
307 $st_ctx = $ctx->snapshot;
309 $ok = eval { local $Level = 1; $code->(@args); 1 };
310 ($err, $child_error) = ($@, $?);
312 # They might have done 'BEGIN { skip_all => "whatever" }'
313 if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && blessed($err) eq 'Test::Builder::Exception')) {
322 if ($start_pid != $$ && !$INC{'Test/Sync/IPC.pm'}) {
323 warn $ok ? "Forked inside subtest, but subtest never finished!\n" : $err;
327 my $trace = $ctx->trace;
330 if(my $bailed = $st_ctx->hub->bailed_out) {
331 my $chub = $child->{Hub};
332 $self->{Stack}->pop($chub);
333 $ctx->bail($bailed->reason);
335 my $code = $st_ctx->hub->exit_code;
337 $err = "Subtest ended with exit code $code" if $code;
340 my $st_hub = $st_ctx->hub;
341 my $plan = $st_hub->plan;
342 my $count = $st_hub->count;
344 if (!$count && (!defined($plan) || "$plan" ne 'SKIP')) {
345 $st_ctx->plan(0) unless defined $plan;
346 $st_ctx->diag('No tests run!');
349 $child->finalize($st_ctx->trace);
355 $? = $child_error if defined $child_error;
357 return $st_hub->is_passing;
362 my $ctx = $self->ctx;
363 release $ctx, $ctx->hub->meta(__PACKAGE__, {})->{Name};
366 sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
367 my ($self, %params) = @_;
369 Test2::API::test2_set_is_end(0);
371 # We leave this a global because it has to be localized and localizing
372 # hash keys is just asking for pain. Also, it was documented.
375 $self->{Original_Pid} = $$;
377 my $ctx = $self->ctx;
378 unless ($params{singleton}) {
379 $ctx->hub->reset_state();
380 $ctx->hub->set_pid($$);
381 $ctx->hub->set_tid(get_tid);
384 my $meta = $ctx->hub->meta(__PACKAGE__, {});
388 Done_Testing => undef,
393 $self->{Exported_To} = undef;
395 $self->{Orig_Handles} ||= do {
396 my $format = $ctx->hub->format;
398 if ($format && $format->isa('Test2::Formatter::TAP')) {
399 $out = $format->handles;
404 $self->use_numbers(1);
407 $self->reset_outputs;
416 no_plan => \&no_plan,
417 skip_all => \&skip_all,
418 tests => \&_plan_tests,
422 my( $self, $cmd, $arg ) = @_;
426 my $ctx = $self->ctx;
429 $ctx->throw("You tried to plan twice") if $hub->plan;
431 local $Level = $Level + 1;
433 if( my $method = $plan_cmds{$cmd} ) {
434 local $Level = $Level + 1;
435 $self->$method($arg);
438 my @args = grep { defined } ( $cmd, $arg );
439 $ctx->throw("plan() doesn't understand @args");
447 my($self, $arg) = @_;
449 my $ctx = $self->ctx;
452 local $Level = $Level + 1;
453 $self->expected_tests($arg);
455 elsif( !defined $arg ) {
456 $ctx->throw("Got an undefined number of tests");
459 $ctx->throw("You said to run 0 tests");
470 my $ctx = $self->ctx;
473 $self->croak("Number of tests must be a positive integer. You gave it '$max'")
474 unless $max =~ /^\+?\d+$/;
483 my $plan = $hub->plan;
484 return 0 unless $plan;
485 return 0 if $plan =~ m/\D/;
491 my($self, $arg) = @_;
493 my $ctx = $self->ctx;
495 if (defined $ctx->hub->plan) {
496 warn "Plan already set, no_plan() is a no-op, this will change to a hard failure in the future.";
501 $ctx->alert("no_plan takes no arguments") if $arg;
503 $ctx->hub->plan('NO PLAN');
510 my($self, $num_tests) = @_;
512 my $ctx = $self->ctx;
514 my $meta = $ctx->hub->meta(__PACKAGE__, {});
516 if ($meta->{Done_Testing}) {
517 my ($file, $line) = @{$meta->{Done_Testing}}[1,2];
518 local $ctx->hub->{ended}; # OMG This is awful.
519 $self->ok(0, "done_testing() was already called at $file line $line");
523 $meta->{Done_Testing} = [$ctx->trace->call];
525 my $plan = $ctx->hub->plan;
526 my $count = $ctx->hub->count;
528 # If done_testing() specified the number of tests, shut off no_plan
529 if( defined $num_tests ) {
530 $ctx->plan($num_tests) if !$plan || $plan eq 'NO PLAN';
532 elsif ($count && defined $num_tests && $count != $num_tests) {
533 $self->ok(0, "planned to run @{[ $self->expected_tests ]} but done_testing() expects $num_tests");
536 $num_tests = $self->current_test;
539 if( $self->expected_tests && $num_tests != $self->expected_tests ) {
540 $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
541 "but done_testing() expects $num_tests");
544 $ctx->plan($num_tests) if $ctx->hub->plan && $ctx->hub->plan eq 'NO PLAN';
546 $ctx->hub->finalize($ctx->trace, 1);
555 my $ctx = $self->ctx;
556 my $plan = $ctx->hub->plan;
559 return( $plan ) if $plan && $plan !~ m/\D/;
560 return('no_plan') if $plan && $plan eq 'NO PLAN';
566 my( $self, $reason ) = @_;
568 my $ctx = $self->ctx;
570 $ctx->hub->meta(__PACKAGE__, {})->{Skip_All} = $reason || 1;
572 # Work around old perl bug
576 while (my @call = caller($level++)) {
577 last unless @call && $call[0];
578 next unless $call[3] =~ m/::BEGIN$/;
583 die 'Label not found for "last T2_SUBTEST_WRAPPER"' if $begin && $ctx->hub->meta(__PACKAGE__, {})->{parent};
586 $ctx->plan(0, SKIP => $reason);
591 my( $self, $pack ) = @_;
593 if( defined $pack ) {
594 $self->{Exported_To} = $pack;
596 return $self->{Exported_To};
601 my( $self, $test, $name ) = @_;
603 my $ctx = $self->ctx;
605 # $test might contain an object which we don't want to accidentally
606 # store, so we turn it into a boolean.
607 $test = $test ? 1 : 0;
609 # In case $name is a string overloaded object, force it to stringify.
610 no warnings qw/uninitialized numeric/;
611 $name = "$name" if defined $name;
613 # Profiling showed that the regex here was a huge time waster, doing the
614 # numeric addition first cuts our profile time from ~300ms to ~50ms
615 $self->diag(<<" ERR") if 0 + $name && $name =~ /^[\d\s]+$/;
616 You named your test '$name'. You shouldn't use numbers for your test names.
619 use warnings qw/uninitialized numeric/;
621 my $trace = $ctx->{trace};
622 my $hub = $ctx->{hub};
629 (name => defined($name) ? $name : ''),
632 $hub->{_meta}->{+__PACKAGE__}->{Test_Results}[ $hub->{count} ] = $result;
634 my $orig_name = $name;
637 my $subevents = delete $self->{subevents};
638 my $subtest_id = delete $self->{subtest_id};
639 my $subtest_buffered = delete $self->{subtest_buffered};
640 my $epkg = 'Test2::Event::Ok';
642 $epkg = 'Test2::Event::Subtest';
643 push @attrs => (subevents => $subevents, subtest_id => $subtest_id, buffered => $subtest_buffered);
647 trace => bless( {%$trace}, 'Test2::Util::Trace'),
650 _meta => {'Test::Builder' => $result},
651 effective_pass => $test,
656 $self->_ok_debug($trace, $orig_name) unless($test);
664 my ($trace, $orig_name) = @_;
666 my $is_todo = defined($self->todo);
668 my $msg = $is_todo ? "Failed (TODO)" : "Failed";
670 my $dfh = $self->_diag_fh;
671 print $dfh "\n" if $ENV{HARNESS_ACTIVE} && $dfh;
673 my (undef, $file, $line) = $trace->call;
674 if (defined $orig_name) {
675 $self->diag(qq[ $msg test '$orig_name'\n]);
676 $self->diag(qq[ at $file line $line.\n]);
679 $self->diag(qq[ $msg test at $file line $line.\n]);
685 local $Level = $Level + 1;
686 return $self->in_todo ? $self->todo_output : $self->failure_output;
690 my ($self, $type, $thing) = @_;
692 return unless ref $$thing;
693 return unless blessed($$thing) || scalar $self->_try(sub{ $$thing->isa('UNIVERSAL') });
698 my $string_meth = overload::Method( $$thing, $type ) || return;
699 $$thing = $$thing->$string_meth();
702 sub _unoverload_str {
705 $self->_unoverload( q[""], $_ ) for @_;
708 sub _unoverload_num {
711 $self->_unoverload( '0+', $_ ) for @_;
714 next unless $self->_is_dualvar($$val);
719 # This is a hack to detect a dualvar such as $!
721 my( $self, $val ) = @_;
723 # Objects are not dualvars.
724 return 0 if ref $val;
726 no warnings 'numeric';
727 my $numval = $val + 0;
728 return ($numval != 0 and $numval ne $val ? 1 : 0);
733 my( $self, $got, $expect, $name ) = @_;
735 my $ctx = $self->ctx;
737 local $Level = $Level + 1;
739 if( !defined $got || !defined $expect ) {
740 # undef only matches undef and nothing else
741 my $test = !defined $got && !defined $expect;
743 $self->ok( $test, $name );
744 $self->_is_diag( $got, 'eq', $expect ) unless $test;
749 release $ctx, $self->cmp_ok( $got, 'eq', $expect, $name );
754 my( $self, $got, $expect, $name ) = @_;
755 my $ctx = $self->ctx;
756 local $Level = $Level + 1;
758 if( !defined $got || !defined $expect ) {
759 # undef only matches undef and nothing else
760 my $test = !defined $got && !defined $expect;
762 $self->ok( $test, $name );
763 $self->_is_diag( $got, '==', $expect ) unless $test;
768 release $ctx, $self->cmp_ok( $got, '==', $expect, $name );
773 my( $self, $type, $val ) = @_;
775 if( defined $$val ) {
776 if( $type eq 'eq' or $type eq 'ne' ) {
777 # quote and force string context
781 # force numeric context
782 $self->_unoverload_num($val);
794 my( $self, $got, $type, $expect ) = @_;
796 $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
798 local $Level = $Level + 1;
799 return $self->diag(<<"DIAGNOSTIC");
807 my( $self, $got, $type ) = @_;
809 $self->_diag_fmt( $type, \$got );
811 local $Level = $Level + 1;
812 return $self->diag(<<"DIAGNOSTIC");
814 expected: anything else
820 my( $self, $got, $dont_expect, $name ) = @_;
821 my $ctx = $self->ctx;
822 local $Level = $Level + 1;
824 if( !defined $got || !defined $dont_expect ) {
825 # undef only matches undef and nothing else
826 my $test = defined $got || defined $dont_expect;
828 $self->ok( $test, $name );
829 $self->_isnt_diag( $got, 'ne' ) unless $test;
834 release $ctx, $self->cmp_ok( $got, 'ne', $dont_expect, $name );
838 my( $self, $got, $dont_expect, $name ) = @_;
839 my $ctx = $self->ctx;
840 local $Level = $Level + 1;
842 if( !defined $got || !defined $dont_expect ) {
843 # undef only matches undef and nothing else
844 my $test = defined $got || defined $dont_expect;
846 $self->ok( $test, $name );
847 $self->_isnt_diag( $got, '!=' ) unless $test;
852 release $ctx, $self->cmp_ok( $got, '!=', $dont_expect, $name );
857 my( $self, $thing, $regex, $name ) = @_;
858 my $ctx = $self->ctx;
860 local $Level = $Level + 1;
862 release $ctx, $self->_regex_ok( $thing, $regex, '=~', $name );
866 my( $self, $thing, $regex, $name ) = @_;
867 my $ctx = $self->ctx;
869 local $Level = $Level + 1;
871 release $ctx, $self->_regex_ok( $thing, $regex, '!~', $name );
875 my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
877 # Bad, these are not comparison operators. Should we include more?
878 my %cmp_ok_bl = map { ( $_, 1 ) } ( "=", "+=", ".=", "x=", "^=", "|=", "||=", "&&=", "...");
881 my( $self, $got, $type, $expect, $name ) = @_;
882 my $ctx = $self->ctx;
884 if ($cmp_ok_bl{$type}) {
885 $ctx->throw("$type is not a valid comparison operator in cmp_ok()");
891 ## no critic (BuiltinFunctions::ProhibitStringyEval)
893 local( $@, $!, $SIG{__DIE__} ); # isolate eval
895 my($pack, $file, $line) = $ctx->trace->call();
897 # This is so that warnings come out at the caller's level
899 #line $line "(eval in cmp_ok) $file"
900 \$test = (\$got $type \$expect);
905 local $Level = $Level + 1;
906 my $ok = $self->ok( $test, $name );
908 # Treat overloaded objects as numbers if we're asked to do a
909 # numeric comparison.
911 = $numeric_cmps{$type}
915 $self->diag(<<"END") unless $succ;
916 An error occurred while using $type:
917 ------------------------------------
919 ------------------------------------
923 $self->$unoverload( \$got, \$expect );
925 if( $type =~ /^(eq|==)$/ ) {
926 $self->_is_diag( $got, $type, $expect );
928 elsif( $type =~ /^(ne|!=)$/ ) {
930 my $eq = ($got eq $expect || $got == $expect)
932 (defined($got) xor defined($expect))
933 || (length($got) != length($expect))
938 $self->_cmp_diag( $got, $type, $expect );
941 $self->_isnt_diag( $got, $type );
945 $self->_cmp_diag( $got, $type, $expect );
948 return release $ctx, $ok;
952 my( $self, $got, $type, $expect ) = @_;
954 $got = defined $got ? "'$got'" : 'undef';
955 $expect = defined $expect ? "'$expect'" : 'undef';
957 local $Level = $Level + 1;
958 return $self->diag(<<"DIAGNOSTIC");
965 sub _caller_context {
968 my( $pack, $file, $line ) = $self->caller(1);
971 $code .= "#line $line $file\n" if defined $file and defined $line;
978 my( $self, $reason ) = @_;
980 my $ctx = $self->ctx;
982 $self->{Bailed_Out} = 1;
990 *BAILOUT = \&BAIL_OUT;
994 my( $self, $why, $name ) = @_;
996 $name = '' unless defined $name;
997 $self->_unoverload_str( \$why );
999 my $ctx = $self->ctx;
1001 $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = {
1009 $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
1010 $name =~ s{\n}{\n# }sg;
1011 $why =~ s{\n}{\n# }sg;
1013 my $tctx = $ctx->snapshot;
1014 $tctx->skip('', $why);
1016 return release $ctx, 1;
1021 my( $self, $why ) = @_;
1024 my $ctx = $self->ctx;
1026 $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = {
1030 type => 'todo_skip',
1034 $why =~ s{\n}{\n# }sg;
1035 my $tctx = $ctx->snapshot;
1036 $tctx->send_event( 'Skip', todo => $why, todo_diag => 1, reason => $why, pass => 0);
1038 return release $ctx, 1;
1043 my( $self, $regex ) = @_;
1044 my $usable_regex = undef;
1046 return $usable_regex unless defined $regex;
1051 if( _is_qr($regex) ) {
1052 $usable_regex = $regex;
1054 # Check for '/foo/' or 'm,foo,'
1055 elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
1056 ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
1059 $usable_regex = length $opts ? "(?$opts)$re" : $re;
1062 return $usable_regex;
1068 # is_regexp() checks for regexes in a robust manner, say if they're
1070 return re::is_regexp($regex) if defined &re::is_regexp;
1071 return ref $regex eq 'Regexp';
1075 my( $self, $thing, $regex, $cmp, $name ) = @_;
1078 my $usable_regex = $self->maybe_regex($regex);
1079 unless( defined $usable_regex ) {
1080 local $Level = $Level + 1;
1081 $ok = $self->ok( 0, $name );
1082 $self->diag(" '$regex' doesn't look much like a regex to me.");
1088 my $context = $self->_caller_context;
1091 ## no critic (BuiltinFunctions::ProhibitStringyEval)
1093 local( $@, $!, $SIG{__DIE__} ); # isolate eval
1095 # No point in issuing an uninit warning, they'll see it in the diagnostics
1096 no warnings 'uninitialized';
1098 $test = eval $context . q{$test = $thing =~ /$usable_regex/ ? 1 : 0};
1101 $test = !$test if $cmp eq '!~';
1103 local $Level = $Level + 1;
1104 $ok = $self->ok( $test, $name );
1108 $thing = defined $thing ? "'$thing'" : 'undef';
1109 my $match = $cmp eq '=~' ? "doesn't match" : "matches";
1111 local $Level = $Level + 1;
1112 $self->diag( sprintf <<'DIAGNOSTIC', $thing, $match, $regex );
1125 my $maybe_fh = shift;
1126 return 0 unless defined $maybe_fh;
1128 return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
1129 return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
1131 return eval { $maybe_fh->isa("IO::Handle") } ||
1132 eval { tied($maybe_fh)->can('TIEHANDLE') };
1137 my( $self, $level ) = @_;
1139 if( defined $level ) {
1147 my( $self, $use_nums ) = @_;
1149 my $ctx = $self->ctx;
1150 my $format = $ctx->hub->format;
1151 unless ($format && $format->can('no_numbers') && $format->can('set_no_numbers')) {
1152 warn "The current formatter does not support 'use_numbers'" if $format;
1153 return release $ctx, 0;
1156 $format->set_no_numbers(!$use_nums) if defined $use_nums;
1158 return release $ctx, $format->no_numbers ? 0 : 1;
1162 for my $method (qw(no_header no_diag)) {
1163 my $set = "set_$method";
1165 my( $self, $no ) = @_;
1167 my $ctx = $self->ctx;
1168 my $format = $ctx->hub->format;
1169 unless ($format && $format->can($set)) {
1170 warn "The current formatter does not support '$method'" if $format;
1175 $format->$set($no) if defined $no;
1177 return release $ctx, $format->$method ? 1 : 0;
1180 no strict 'refs'; ## no critic
1186 my( $self, $no ) = @_;
1188 my $ctx = $self->ctx;
1190 $ctx->hub->set_no_ending($no) if defined $no;
1192 return release $ctx, $ctx->hub->no_ending;
1199 my $ctx = $self->ctx;
1200 $ctx->diag(join '' => map {defined($_) ? $_ : 'undef'} @_);
1210 my $ctx = $self->ctx;
1211 $ctx->note(join '' => map {defined($_) ? $_ : 'undef'} @_);
1221 require Data::Dumper;
1226 my $dumper = Data::Dumper->new( [$_] );
1227 $dumper->Indent(1)->Terse(1);
1228 $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
1237 my( $self, $fh ) = @_;
1239 my $ctx = $self->ctx;
1240 my $format = $ctx->hub->format;
1242 return unless $format && $format->isa('Test2::Formatter::TAP');
1244 $format->handles->[Test2::Formatter::TAP::OUT_STD()] = $self->_new_fh($fh)
1247 return $format->handles->[Test2::Formatter::TAP::OUT_STD()];
1250 sub failure_output {
1251 my( $self, $fh ) = @_;
1253 my $ctx = $self->ctx;
1254 my $format = $ctx->hub->format;
1256 return unless $format && $format->isa('Test2::Formatter::TAP');
1258 $format->handles->[Test2::Formatter::TAP::OUT_ERR()] = $self->_new_fh($fh)
1261 return $format->handles->[Test2::Formatter::TAP::OUT_ERR()];
1265 my( $self, $fh ) = @_;
1267 my $ctx = $self->ctx;
1268 my $format = $ctx->hub->format;
1270 return unless $format && $format->isa('Test::Builder::Formatter');
1272 $format->handles->[Test::Builder::Formatter::OUT_TODO()] = $self->_new_fh($fh)
1275 return $format->handles->[Test::Builder::Formatter::OUT_TODO()];
1280 my($file_or_fh) = shift;
1283 if( $self->is_fh($file_or_fh) ) {
1286 elsif( ref $file_or_fh eq 'SCALAR' ) {
1287 # Scalar refs as filehandles was added in 5.8.
1289 open $fh, ">>", $file_or_fh
1290 or $self->croak("Can't open scalar ref $file_or_fh: $!");
1292 # Emulate scalar ref filehandles with a tie.
1294 $fh = Test::Builder::IO::Scalar->new($file_or_fh)
1295 or $self->croak("Can't tie scalar ref $file_or_fh");
1299 open $fh, ">", $file_or_fh
1300 or $self->croak("Can't open test output log $file_or_fh: $!");
1309 my $old_fh = select $fh;
1320 my $ctx = $self->ctx;
1321 my $format = $ctx->hub->format;
1323 return unless $format && $format->isa('Test2::Formatter::TAP');
1324 $format->set_handles([@{$self->{Orig_Handles}}]) if $self->{Orig_Handles};
1332 my $ctx = $self->ctx;
1333 $ctx->alert(join "", @_);
1339 my $ctx = $self->ctx;
1340 $ctx->throw(join "", @_);
1346 my( $self, $num ) = @_;
1348 my $ctx = $self->ctx;
1349 my $hub = $ctx->hub;
1351 if( defined $num ) {
1352 $hub->set_count($num);
1354 # If the test counter is being pushed forward fill in the details.
1355 my $test_results = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results};
1356 if( $num > @$test_results ) {
1357 my $start = @$test_results ? @$test_results : 0;
1358 for( $start .. $num - 1 ) {
1359 $test_results->[$_] = {
1362 reason => 'incrementing test number',
1368 # If backward, wipe history. Its their funeral.
1369 elsif( $num < @$test_results ) {
1370 $#{$test_results} = $num - 1;
1373 return release $ctx, $hub->count;
1380 my $ctx = $self->ctx;
1381 my $hub = $ctx->hub;
1385 $hub->set_failed(0) if $bool;
1386 $hub->is_passing($bool);
1389 return release $ctx, $hub->is_passing;
1396 my $ctx = $self->ctx;
1397 my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results};
1399 return map { $_->{'ok'} } @$data;
1405 my $ctx = $self->ctx;
1406 my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results};
1413 my( $self, $pack, $set, $new_value ) = @_;
1415 my $ctx = $self->ctx;
1417 $pack ||= $ctx->trace->package || $self->exported_to;
1420 return unless $pack;
1422 no strict 'refs'; ## no critic
1424 my $old_value = ${ $pack . '::TODO' };
1425 $set and ${ $pack . '::TODO' } = $new_value;
1430 my( $self, $pack ) = @_;
1432 local $Level = $Level + 1;
1433 my $ctx = $self->ctx;
1436 my $meta = $ctx->hub->meta(__PACKAGE__, {todo => []})->{todo};
1437 return $meta->[-1]->[1] if $meta && @$meta;
1439 $pack ||= $ctx->trace->package;
1441 return unless $pack;
1443 no strict 'refs'; ## no critic
1445 return ${ $pack . '::TODO' };
1451 local $Level = $Level + 1;
1452 my $ctx = $self->ctx;
1455 my $meta = $ctx->hub->meta(__PACKAGE__, {todo => []})->{todo};
1456 return 1 if $meta && @$meta;
1458 my $pack = $ctx->trace->package || return 0;
1460 no strict 'refs'; ## no critic
1462 my $todo = ${ $pack . '::TODO' };
1464 return 0 unless defined $todo;
1465 return 0 if "$todo" eq '';
1471 my $message = @_ ? shift : '';
1473 my $ctx = $self->ctx;
1475 my $hub = $ctx->hub;
1476 my $filter = $hub->pre_filter(sub {
1477 my ($active_hub, $e) = @_;
1479 # Turn a diag into a todo diag
1480 return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag';
1483 if ($hub == $active_hub && $e->isa('Test2::Event::Ok')) {
1484 $e->set_todo($message);
1485 $e->set_effective_pass(1);
1487 if (my $result = $e->get_meta(__PACKAGE__)) {
1488 $result->{reason} ||= $message;
1489 $result->{type} ||= 'todo';
1497 push @{$ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}} => [$filter, $message];
1507 my $ctx = $self->ctx;
1509 my $set = pop @{$ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}};
1511 $ctx->throw('todo_end() called without todo_start()') unless $set;
1513 $ctx->hub->pre_unfilter($set->[0]);
1521 sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
1524 my $ctx = $self->ctx;
1526 my $trace = $ctx->trace;
1528 return wantarray ? $trace->call : $trace->package;
1533 my( $self, $code, %opts ) = @_;
1538 local $!; # eval can mess up $!
1539 local $@; # don't set $@ in the test
1540 local $SIG{__DIE__}; # don't trip an outside DIE handler.
1541 $return = eval { $code->() };
1545 die $error if $error and $opts{die_on_fail};
1547 return wantarray ? ( $return, $error ) : $return;
1552 my ($ctx, $real_exit_code, $new) = @_;
1555 my $octx = $self->ctx;
1556 $ctx = $octx->snapshot;
1560 return if $ctx->hub->no_ending;
1561 return if $ctx->hub->meta(__PACKAGE__, {})->{Ending}++;
1563 # Don't bother with an ending if this is a forked copy. Only the parent
1564 # should do the ending.
1565 return unless $self->{Original_Pid} == $$;
1567 my $hub = $ctx->hub;
1568 return if $hub->bailed_out;
1570 my $plan = $hub->plan;
1571 my $count = $hub->count;
1572 my $failed = $hub->failed;
1573 my $passed = $hub->is_passing;
1574 return unless $plan || $count || $failed;
1576 # Ran tests but never declared a plan or hit done_testing
1577 if( !$hub->plan and $hub->count ) {
1578 $self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
1580 if($real_exit_code) {
1581 $self->diag(<<"FAIL");
1582 Looks like your test exited with $real_exit_code just after $count.
1584 $$new ||= $real_exit_code;
1588 # But if the tests ran, handle exit code.
1590 my $exit_code = $failed <= 254 ? $failed : 254;
1591 $$new ||= $exit_code;
1599 if ($real_exit_code && !$count) {
1600 $self->diag("Looks like your test exited with $real_exit_code before it could output anything.");
1601 $$new ||= $real_exit_code;
1605 return if $plan && "$plan" eq 'SKIP';
1608 $self->diag('No tests run!');
1613 if ($real_exit_code) {
1614 $self->diag(<<"FAIL");
1615 Looks like your test exited with $real_exit_code just after $count.
1617 $$new ||= $real_exit_code;
1621 if ($plan eq 'NO PLAN') {
1622 $ctx->plan( $count );
1626 # Figure out if we passed or failed and print helpful messages.
1627 my $num_extra = $count - $plan;
1629 if ($num_extra != 0) {
1630 my $s = $plan == 1 ? '' : 's';
1631 $self->diag(<<"FAIL");
1632 Looks like you planned $plan test$s but ran $count.
1637 my $s = $failed == 1 ? '' : 's';
1639 my $qualifier = $num_extra == 0 ? '' : ' run';
1641 $self->diag(<<"FAIL");
1642 Looks like you failed $failed test$s of $count$qualifier.
1646 if (!$passed && !$failed && $count && !$num_extra) {
1647 $ctx->diag(<<"FAIL");
1648 All assertions passed, but errors were encountered.
1654 $exit_code = $failed <= 254 ? $failed : 254;
1656 elsif ($num_extra != 0) {
1663 $$new ||= $exit_code;
1667 # Some things used this even though it was private... I am looking at you
1668 # Test::Builder::Prefix...
1669 sub _print_comment {
1670 my( $self, $fh, @msgs ) = @_;
1672 return if $self->no_diag;
1673 return unless @msgs;
1675 # Prevent printing headers when compiling (i.e. -c)
1678 # Smash args together like print does.
1679 # Convert undef to 'undef' so its readable.
1680 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1682 # Escape the beginning, _print will take care of the rest.
1685 local( $\, $", $, ) = ( undef, ' ', '' );
1691 # This is used by Test::SharedFork to turn on IPC after the fact. Not
1692 # documenting because I do not want it used. The method name is borrowed from
1694 # Once Test2 stuff goes stable this method will be removed and Test::SharedFork
1695 # will be made smarter.
1696 sub coordinate_forks {
1704 Test2::API::test2_ipc_enable_polling();
1705 my $ipc = Test2::IPC::apply_ipc($self->{Stack});
1706 $ipc->set_no_fatal(1);
1707 Test2::API::test2_no_wait(1);
1708 Test2::API::test2_ipc_enable_shm();
1717 Test::Builder - Backend for building test libraries
1721 package My::Test::Module;
1722 use base 'Test::Builder::Module';
1724 my $CLASS = __PACKAGE__;
1727 my($test, $name) = @_;
1728 my $tb = $CLASS->builder;
1730 $tb->ok($test, $name);
1736 L<Test::Simple> and L<Test::More> have proven to be popular testing modules,
1737 but they're not always flexible enough. Test::Builder provides a
1738 building block upon which to write your own test libraries I<which can
1747 my $Test = Test::Builder->new;
1749 Returns a Test::Builder object representing the current state of the
1752 Since you only run one test per program C<new> always returns the same
1753 Test::Builder object. No matter how many times you call C<new()>, you're
1754 getting the same object. This is called a singleton. This is done so that
1755 multiple modules share such global information as the test counter and
1756 where test output is going.
1758 If you want a completely new Test::Builder object different from the
1759 singleton, use C<create>.
1763 my $Test = Test::Builder->create;
1765 Ok, so there can be more than one Test::Builder object and this is how
1766 you get it. You might use this instead of C<new()> if you're testing
1767 a Test::Builder based module, but otherwise you probably want C<new>.
1769 B<NOTE>: the implementation is not complete. C<level>, for example, is still
1770 shared by B<all> Test::Builder objects, even ones created using this method.
1771 Also, the method name may change in the future.
1775 $builder->subtest($name, \&subtests, @args);
1777 See documentation of C<subtest> in Test::More.
1779 C<subtest> also, and optionally, accepts arguments which will be passed to the
1784 diag $builder->name;
1786 Returns the name of the current builder. Top level builders default to C<$0>
1787 (the name of the executable). Child builders are named via the C<child>
1788 method. If no name is supplied, will be named "Child of $parent->name".
1794 Reinitializes the Test::Builder singleton to its original state.
1795 Mostly useful for tests run in persistent environments where the same
1796 test might be run multiple times in the same process.
1800 =head2 Setting up tests
1802 These methods are for setting up tests and declaring how many there
1803 are. You usually only want to call one of these methods.
1809 $Test->plan('no_plan');
1810 $Test->plan( skip_all => $reason );
1811 $Test->plan( tests => $num_tests );
1813 A convenient way to set up your tests. Call this and Test::Builder
1814 will print the appropriate headers and take the appropriate actions.
1816 If you call C<plan()>, don't call any of the other methods below.
1818 =item B<expected_tests>
1820 my $max = $Test->expected_tests;
1821 $Test->expected_tests($max);
1823 Gets/sets the number of tests we expect this test to run and prints out
1824 the appropriate headers.
1831 Declares that this test will run an indeterminate number of tests.
1834 =item B<done_testing>
1836 $Test->done_testing();
1837 $Test->done_testing($num_tests);
1839 Declares that you are done testing, no more tests will be run after this point.
1841 If a plan has not yet been output, it will do so.
1843 $num_tests is the number of tests you planned to run. If a numbered
1844 plan was already declared, and if this contradicts, a failing test
1845 will be run to reflect the planning mistake. If C<no_plan> was declared,
1848 If C<done_testing()> is called twice, the second call will issue a
1851 If C<$num_tests> is omitted, the number of tests run will be used, like
1854 C<done_testing()> is, in effect, used when you'd want to use C<no_plan>, but
1855 safer. You'd use it like so:
1857 $Test->ok($a == $b);
1858 $Test->done_testing();
1860 Or to plan a variable number of tests:
1862 for my $test (@tests) {
1865 $Test->done_testing(scalar @tests);
1870 $plan = $Test->has_plan
1872 Find out whether a plan has been defined. C<$plan> is either C<undef> (no plan
1873 has been set), C<no_plan> (indeterminate # of tests) or an integer (the number
1879 $Test->skip_all($reason);
1881 Skips all the tests, using the given C<$reason>. Exits immediately with 0.
1883 =item B<exported_to>
1885 my $pack = $Test->exported_to;
1886 $Test->exported_to($pack);
1888 Tells Test::Builder what package you exported your functions to.
1890 This method isn't terribly useful since modules which share the same
1891 Test::Builder object might get exported to different packages and only
1892 the last one will be honored.
1896 =head2 Running tests
1898 These actually run the tests, analogous to the functions in Test::More.
1900 They all return true if the test passed, false if the test failed.
1902 C<$name> is always optional.
1908 $Test->ok($test, $name);
1910 Your basic test. Pass if C<$test> is true, fail if $test is false. Just
1911 like Test::Simple's C<ok()>.
1915 $Test->is_eq($got, $expected, $name);
1917 Like Test::More's C<is()>. Checks if C<$got eq $expected>. This is the
1920 C<undef> only ever matches another C<undef>.
1924 $Test->is_num($got, $expected, $name);
1926 Like Test::More's C<is()>. Checks if C<$got == $expected>. This is the
1929 C<undef> only ever matches another C<undef>.
1933 $Test->isnt_eq($got, $dont_expect, $name);
1935 Like L<Test::More>'s C<isnt()>. Checks if C<$got ne $dont_expect>. This is
1940 $Test->isnt_num($got, $dont_expect, $name);
1942 Like L<Test::More>'s C<isnt()>. Checks if C<$got ne $dont_expect>. This is
1943 the numeric version.
1947 $Test->like($thing, qr/$regex/, $name);
1948 $Test->like($thing, '/$regex/', $name);
1950 Like L<Test::More>'s C<like()>. Checks if $thing matches the given C<$regex>.
1954 $Test->unlike($thing, qr/$regex/, $name);
1955 $Test->unlike($thing, '/$regex/', $name);
1957 Like L<Test::More>'s C<unlike()>. Checks if $thing B<does not match> the
1962 $Test->cmp_ok($thing, $type, $that, $name);
1964 Works just like L<Test::More>'s C<cmp_ok()>.
1966 $Test->cmp_ok($big_num, '!=', $other_big_num);
1970 =head2 Other Testing Methods
1972 These are methods which are used in the course of writing a test but are not themselves tests.
1978 $Test->BAIL_OUT($reason);
1980 Indicates to the L<Test::Harness> that things are going so badly all
1981 testing should terminate. This includes running any additional test
1984 It will exit with 255.
1987 BAIL_OUT() used to be BAILOUT()
1994 Skips the current test, reporting C<$why>.
1999 $Test->todo_skip($why);
2001 Like C<skip()>, only it will declare the test as failing and TODO. Similar
2004 print "not ok $tnum # TODO $why\n";
2006 =begin _unimplemented
2011 $Test->skip_rest($reason);
2013 Like C<skip()>, only it skips all the rest of the tests you plan to run
2014 and terminates the test.
2016 If you're running under C<no_plan>, it skips once and terminates the
2024 =head2 Test building utility methods
2026 These methods are useful when writing your own test methods.
2030 =item B<maybe_regex>
2032 $Test->maybe_regex(qr/$regex/);
2033 $Test->maybe_regex('/$regex/');
2035 This method used to be useful back when Test::Builder worked on Perls
2036 before 5.6 which didn't have qr//. Now its pretty useless.
2038 Convenience method for building testing functions that take regular
2039 expressions as arguments.
2041 Takes a quoted regular expression produced by C<qr//>, or a string
2042 representing a regular expression.
2044 Returns a Perl value which may be used instead of the corresponding
2045 regular expression, or C<undef> if its argument is not recognized.
2047 For example, a version of C<like()>, sans the useful diagnostic messages,
2048 could be written as:
2051 my ($self, $thing, $regex, $name) = @_;
2052 my $usable_regex = $self->maybe_regex($regex);
2053 die "expecting regex, found '$regex'\n"
2054 unless $usable_regex;
2055 $self->ok($thing =~ m/$usable_regex/, $name);
2061 my $is_fh = $Test->is_fh($thing);
2063 Determines if the given C<$thing> can be used as a filehandle.
2078 $Test->level($how_high);
2080 How far up the call stack should C<$Test> look when reporting where the
2085 Setting L<$Test::Builder::Level> overrides. This is typically useful
2091 local $Test::Builder::Level = $Test::Builder::Level + 1;
2095 To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant.
2097 =item B<use_numbers>
2099 $Test->use_numbers($on_or_off);
2101 Whether or not the test should output numbers. That is, this if true:
2113 Most useful when you can't depend on the test output order, such as
2114 when threads or forking is involved.
2120 $Test->no_diag($no_diag);
2122 If set true no diagnostics will be printed. This includes calls to
2127 $Test->no_ending($no_ending);
2129 Normally, Test::Builder does some extra diagnostics when the test
2130 ends. It also changes the exit code as described below.
2132 If this is true, none of that will be done.
2136 $Test->no_header($no_header);
2138 If set to true, no "1..N" header will be printed.
2144 Controlling where the test output goes.
2146 It's ok for your test to change where STDOUT and STDERR point to,
2147 Test::Builder's default output settings will not be affected.
2155 Prints out the given C<@msgs>. Like C<print>, arguments are simply
2158 Normally, it uses the C<failure_output()> handle, but if this is for a
2159 TODO test, the C<todo_output()> handle is used.
2161 Output will be indented and marked with a # so as not to interfere
2162 with test output. A newline will be put on the end if there isn't one
2165 We encourage using this rather than calling print directly.
2167 Returns false. Why? Because C<diag()> is often used in conjunction with
2168 a failing test (C<ok() || diag()>) it "passes through" the failure.
2170 return ok(...) || diag(...);
2173 Mark Fowler <mark@twoshortplanks.com>
2179 Like C<diag()>, but it prints to the C<output()> handle so it will not
2180 normally be seen by the user except in verbose mode.
2184 my @dump = $Test->explain(@msgs);
2186 Will dump the contents of any references in a human readable format.
2187 Handy for things like...
2189 is_deeply($have, $want) || diag explain $have;
2193 is_deeply($have, $want) || note explain $have;
2197 =item B<failure_output>
2199 =item B<todo_output>
2201 my $filehandle = $Test->output;
2202 $Test->output($filehandle);
2203 $Test->output($filename);
2204 $Test->output(\$scalar);
2206 These methods control where Test::Builder will print its output.
2207 They take either an open C<$filehandle>, a C<$filename> to open and write to
2208 or a C<$scalar> reference to append to. It will always return a C<$filehandle>.
2210 B<output> is where normal "ok/not ok" test output goes.
2214 B<failure_output> is where diagnostic output on test failures and
2215 C<diag()> goes. It is normally not read by Test::Harness and instead is
2216 displayed to the user.
2220 C<todo_output> is used instead of C<failure_output()> for the
2221 diagnostics of a failing TODO test. These will not be seen by the
2230 Resets all the output filehandles back to their defaults.
2234 $tb->carp(@message);
2236 Warns with C<@message> but the message will appear to come from the
2237 point where the original test function was called (C<< $tb->caller >>).
2241 $tb->croak(@message);
2243 Dies with C<@message> but the message will appear to come from the
2244 point where the original test function was called (C<< $tb->caller >>).
2250 =head2 Test Status and Info
2254 =item B<current_test>
2256 my $curr_test = $Test->current_test;
2257 $Test->current_test($num);
2259 Gets/sets the current test number we're on. You usually shouldn't
2262 If set forward, the details of the missing tests are filled in as 'unknown'.
2263 if set backward, the details of the intervening tests are deleted. You
2264 can erase history if you really want to.
2269 my $ok = $builder->is_passing;
2271 Indicates if the test suite is currently passing.
2273 More formally, it will be false if anything has happened which makes
2274 it impossible for the test suite to pass. True otherwise.
2276 For example, if no tests have run C<is_passing()> will be true because
2277 even though a suite with no tests is a failure you can add a passing
2278 test to it and start passing.
2280 Don't think about it too much.
2285 my @tests = $Test->summary;
2287 A simple summary of the tests so far. True for pass, false for fail.
2288 This is a logical pass/fail, so todos are passes.
2290 Of course, test #1 is $tests[0], etc...
2295 my @tests = $Test->details;
2297 Like C<summary()>, but with a lot more detail.
2299 $tests[$test_num - 1] =
2300 { 'ok' => is the test considered a pass?
2301 actual_ok => did it literally say 'ok'?
2302 name => name of the test (if any)
2303 type => type of test (if any, see below).
2304 reason => reason for the above (if any)
2307 'ok' is true if Test::Harness will consider the test to be a pass.
2309 'actual_ok' is a reflection of whether or not the test literally
2310 printed 'ok' or 'not ok'. This is for examining the result of 'todo'
2313 'name' is the name of the test.
2315 'type' indicates if it was a special test. Normal tests have a type
2316 of ''. Type can be one of the following:
2320 todo_skip see todo_skip()
2323 Sometimes the Test::Builder test counter is incremented without it
2324 printing any test output, for example, when C<current_test()> is changed.
2325 In these cases, Test::Builder doesn't know the result of the test, so
2326 its type is 'unknown'. These details for these tests are filled in.
2327 They are considered ok, but the name and actual_ok is left C<undef>.
2329 For example "not ok 23 - hole count # TODO insufficient donuts" would
2330 result in this structure:
2332 $tests[22] = # 23 - 1, since arrays start from 0.
2333 { ok => 1, # logically, the test passed since its todo
2334 actual_ok => 0, # in absolute terms, it failed
2335 name => 'hole count',
2337 reason => 'insufficient donuts'
2343 my $todo_reason = $Test->todo;
2344 my $todo_reason = $Test->todo($pack);
2346 If the current tests are considered "TODO" it will return the reason,
2347 if any. This reason can come from a C<$TODO> variable or the last call
2350 Since a TODO test does not need a reason, this function can return an
2351 empty string even when inside a TODO block. Use C<< $Test->in_todo >>
2352 to determine if you are currently inside a TODO block.
2354 C<todo()> is about finding the right package to look for C<$TODO> in. It's
2355 pretty good at guessing the right package to look at. It first looks for
2356 the caller based on C<$Level + 1>, since C<todo()> is usually called inside
2357 a test function. As a last resort it will use C<exported_to()>.
2359 Sometimes there is some confusion about where C<todo()> should be looking
2360 for the C<$TODO> variable. If you want to be sure, tell it explicitly
2365 my $todo_reason = $Test->find_TODO();
2366 my $todo_reason = $Test->find_TODO($pack);
2368 Like C<todo()> but only returns the value of C<$TODO> ignoring
2371 Can also be used to set C<$TODO> to a new value while returning the
2374 my $old_reason = $Test->find_TODO($pack, 1, $new_reason);
2378 my $in_todo = $Test->in_todo;
2380 Returns true if the test is currently inside a TODO block.
2384 $Test->todo_start();
2385 $Test->todo_start($message);
2387 This method allows you declare all subsequent tests as TODO tests, up until
2388 the C<todo_end> method has been called.
2390 The C<TODO:> and C<$TODO> syntax is generally pretty good about figuring out
2391 whether or not we're in a TODO test. However, often we find that this is not
2392 possible to determine (such as when we want to use C<$TODO> but
2393 the tests are being executed in other packages which can't be inferred
2396 Note that you can use this to nest "todo" tests
2398 $Test->todo_start('working on this');
2400 $Test->todo_start('working on that');
2405 This is generally not recommended, but large testing systems often have weird
2408 We've tried to make this also work with the TODO: syntax, but it's not
2409 guaranteed and its use is also discouraged:
2412 local $TODO = 'We have work to do!';
2413 $Test->todo_start('working on this');
2415 $Test->todo_start('working on that');
2421 Pick one style or another of "TODO" to be on the safe side.
2428 Stops running tests as "TODO" tests. This method is fatal if called without a
2429 preceding C<todo_start> method call.
2433 my $package = $Test->caller;
2434 my($pack, $file, $line) = $Test->caller;
2435 my($pack, $file, $line) = $Test->caller($height);
2437 Like the normal C<caller()>, except it reports according to your C<level()>.
2439 C<$height> will be added to the C<level()>.
2441 If C<caller()> winds up off the top of the stack it report the highest context.
2447 If all your tests passed, Test::Builder will exit with zero (which is
2448 normal). If anything failed it will exit with how many failed. If
2449 you run less (or more) tests than you planned, the missing (or extras)
2450 will be considered failures. If no tests were ever run Test::Builder
2451 will throw a warning and exit with 255. If the test died, even after
2452 having successfully completed all its tests, it will still be
2453 considered a failure and will exit with 255.
2455 So the exit codes are...
2457 0 all tests successful
2458 255 test died or all passed but wrong # of tests run
2459 any other number how many failed (including missing or extras)
2461 If you fail more than 254 tests, it will be reported as 254.
2465 In perl 5.8.1 and later, Test::Builder is thread-safe. The test number is
2466 shared by all threads. This means if one thread sets the test number using
2467 C<current_test()> they will all be effected.
2469 While versions earlier than 5.8.1 had threads they contain too many
2472 Test::Builder is only thread-aware if threads.pm is loaded I<before>
2477 An informative hash, accessible via C<details()>, is stored for each
2478 test you perform. So memory usage will scale linearly with each test
2479 run. Although this is not a problem for most test suites, it can
2480 become an issue if you do large (hundred thousands to million)
2481 combinatorics tests in the same run.
2483 In such cases, you are advised to either split the test file into smaller
2484 ones, or use a reverse approach, doing "normal" (code) compares and
2485 triggering C<fail()> should anything go unexpected.
2487 Future versions of Test::Builder will have a way to turn history off.
2492 CPAN can provide the best examples. L<Test::Simple>, L<Test::More>,
2493 L<Test::Exception> and L<Test::Differences> all use Test::Builder.
2497 L<Test::Simple>, L<Test::More>, L<Test::Harness>
2501 Original code by chromatic, maintained by Michael G Schwern
2502 E<lt>schwern@pobox.comE<gt>
2508 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
2514 Copyright 2002-2008 by chromatic E<lt>chromatic@wgz.orgE<gt> and
2515 Michael G Schwern E<lt>schwern@pobox.comE<gt>.
2517 This program is free software; you can redistribute it and/or
2518 modify it under the same terms as Perl itself.
2520 See F<http://www.perl.com/perl/misc/Artistic.html>