7 our $VERSION = '1.302113';
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;
46 my $hub = $self->{Stack}->top;
48 # Take a reference to the hash key, we do this to avoid closing over $self
49 # which is the singleton. We use a reference because the value could change
51 my $epkgr = \$self->{Exported_To};
53 #$hub->add_context_aquire(sub {$_[0]->{level} += $Level - 1});
55 $hub->pre_filter(sub {
56 my ($active_hub, $e) = @_;
59 my $cpkg = $e->{trace} ? $e->{trace}->{frame}->[0] : undef;
64 $todo = ${"$cpkg\::TODO"} if $cpkg;
65 $todo = ${"$epkg\::TODO"} if $epkg && !$todo;
67 return $e unless $todo;
69 # Turn a diag into a todo diag
70 return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag';
72 if ($active_hub == $hub) {
73 $e->set_todo($todo) if $e->can('set_todo');
74 $e->add_amnesty({tag => 'TODO', details => $todo});
77 $e->add_amnesty({tag => 'TODO', details => $todo, inherited => 1});
81 if ($e->isa('Test2::Event::Ok')) {
82 $e->set_effective_pass(1);
84 if (my $result = $e->get_meta(__PACKAGE__)) {
85 $result->{reason} ||= $todo;
86 $result->{type} ||= 'todo';
99 Test2::API::test2_load() unless Test2::API::test2_in_preload();
106 $Test = $class->create(singleton => 1);
108 Test2::API::test2_add_callback_post_load(
110 $Test->{Original_Pid} = $$ if !$Test->{Original_Pid} || $Test->{Original_Pid} == 0;
111 $Test->reset(singleton => 1);
112 $Test->_add_ts_hooks;
116 # Non-TB tools normally expect 0 added to the level. $Level is normally 1. So
117 # we only want the level to change if $Level != 1.
118 # TB->ctx compensates for this later.
119 Test2::API::test2_add_callback_context_aquire(sub { $_[0]->{level} += $Level - 1 });
121 Test2::API::test2_add_callback_exit(sub { $Test->_ending(@_) });
123 Test2::API::test2_ipc()->set_no_fatal(1) if USE_THREADS;
132 my $self = bless {}, $class;
133 if ($params{singleton}) {
134 $self->{Stack} = Test2::API::test2_stack();
137 $self->{Stack} = Test2::API::Stack->new;
138 $self->{Stack}->new_hub(
139 formatter => Test::Builder::Formatter->new,
140 ipc => Test2::API::test2_ipc(),
143 $self->reset(%params);
144 $self->_add_ts_hooks;
153 # 1 for our frame, another for the -1 off of $Level in our hook at the top.
156 stack => $self->{Stack},
165 my $ctx = $self->ctx;
166 my $chub = $self->{Hub} || $ctx->hub;
169 my $meta = $chub->meta(__PACKAGE__, {});
170 my $parent = $meta->{parent};
172 return undef unless $parent;
176 Stack => $self->{Stack},
182 my( $self, $name ) = @_;
184 $name ||= "Child of " . $self->name;
185 my $ctx = $self->ctx;
187 my $parent = $ctx->hub;
188 my $pmeta = $parent->meta(__PACKAGE__, {});
189 $self->croak("You already have a child named ($pmeta->{child}) running")
192 $pmeta->{child} = $name;
194 # Clear $TODO for the child.
195 my $orig_TODO = $self->find_TODO(undef, 1, undef);
199 my $hub = $ctx->stack->new_hub(
200 class => 'Test2::Hub::Subtest',
203 $hub->pre_filter(sub {
204 my ($active_hub, $e) = @_;
206 # Turn a diag into a todo diag
207 return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag';
210 }, inherit => 1) if $orig_TODO;
212 $hub->listen(sub { push @$subevents => $_[1] });
214 $hub->set_nested( $parent->nested + 1 );
216 my $meta = $hub->meta(__PACKAGE__, {});
217 $meta->{Name} = $name;
218 $meta->{TODO} = $orig_TODO;
219 $meta->{TODO_PKG} = $ctx->trace->package;
220 $meta->{parent} = $parent;
221 $meta->{Test_Results} = [];
222 $meta->{subevents} = $subevents;
223 $meta->{subtest_id} = $hub->id;
224 $meta->{subtest_buffered} = $parent->format ? 0 : 1;
226 $self->_add_ts_hooks;
229 return bless { Original_Pid => $$, Stack => $self->{Stack}, Hub => $hub, no_log_results => $self->{no_log_results} }, blessed($self);
237 my $st_ctx = $self->ctx;
238 my $chub = $self->{Hub} || return $st_ctx->release;
240 my $meta = $chub->meta(__PACKAGE__, {});
241 if ($meta->{child}) {
242 $self->croak("Can't call finalize() with child ($meta->{child}) active");
245 local $? = 0; # don't fail if $subtests happened to set $? nonzero
247 $self->{Stack}->pop($chub);
249 $self->find_TODO($meta->{TODO_PKG}, 1, $meta->{TODO});
251 my $parent = $self->parent;
252 my $ctx = $parent->ctx;
253 my $trace = $ctx->trace;
254 delete $ctx->hub->meta(__PACKAGE__, {})->{child};
256 $chub->finalize($trace->snapshot(hid => $chub->hid, nested => $chub->nested), 1)
262 my $plan = $chub->plan || 0;
263 my $count = $chub->count;
264 my $failed = $chub->failed;
265 my $passed = $chub->is_passing;
267 my $num_extra = $plan =~ m/\D/ ? 0 : $count - $plan;
268 if ($count && $num_extra != 0) {
269 my $s = $plan == 1 ? '' : 's';
270 $st_ctx->diag(<<"FAIL");
271 Looks like you planned $plan test$s but ran $count.
276 my $s = $failed == 1 ? '' : 's';
278 my $qualifier = $num_extra == 0 ? '' : ' run';
280 $st_ctx->diag(<<"FAIL");
281 Looks like you failed $failed test$s of $count$qualifier.
285 if (!$passed && !$failed && $count && !$num_extra) {
286 $st_ctx->diag(<<"FAIL");
287 All assertions inside the subtest passed, but errors were encountered.
293 unless ($chub->bailed_out) {
294 my $plan = $chub->plan;
295 if ( $plan && $plan eq 'SKIP' ) {
296 $parent->skip($chub->skip_reason, $meta->{Name});
298 elsif ( !$chub->count ) {
299 $parent->ok( 0, sprintf q[No tests run for subtest "%s"], $meta->{Name} );
302 $parent->{subevents} = $meta->{subevents};
303 $parent->{subtest_id} = $meta->{subtest_id};
304 $parent->{subtest_buffered} = $meta->{subtest_buffered};
305 $parent->ok( $chub->is_passing, $meta->{Name} );
310 return $chub->is_passing;
315 my ($name, $code, @args) = @_;
316 my $ctx = $self->ctx;
317 $ctx->throw("subtest()'s second argument must be a code ref")
318 unless $code && reftype($code) eq 'CODE';
320 $name ||= "Child of " . $self->name;
322 $ctx->note("Subtest: $name");
324 my $child = $self->child($name);
328 my ($ok, $err, $finished, $child_error);
329 T2_SUBTEST_WRAPPER: {
330 my $ctx = $self->ctx;
331 $st_ctx = $ctx->snapshot;
333 $ok = eval { local $Level = 1; $code->(@args); 1 };
334 ($err, $child_error) = ($@, $?);
336 # They might have done 'BEGIN { skip_all => "whatever" }'
337 if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && blessed($err) eq 'Test::Builder::Exception')) {
346 if ($start_pid != $$ && !$INC{'Test2/IPC.pm'}) {
347 warn $ok ? "Forked inside subtest, but subtest never finished!\n" : $err;
351 my $trace = $ctx->trace;
354 if(my $bailed = $st_ctx->hub->bailed_out) {
355 my $chub = $child->{Hub};
356 $self->{Stack}->pop($chub);
357 $ctx->bail($bailed->reason);
359 my $code = $st_ctx->hub->exit_code;
361 $err = "Subtest ended with exit code $code" if $code;
364 my $st_hub = $st_ctx->hub;
365 my $plan = $st_hub->plan;
366 my $count = $st_hub->count;
368 if (!$count && (!defined($plan) || "$plan" ne 'SKIP')) {
369 $st_ctx->plan(0) unless defined $plan;
370 $st_ctx->diag('No tests run!');
373 $child->finalize($st_ctx->trace);
379 $? = $child_error if defined $child_error;
381 return $st_hub->is_passing;
386 my $ctx = $self->ctx;
387 release $ctx, $ctx->hub->meta(__PACKAGE__, {})->{Name};
390 sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
391 my ($self, %params) = @_;
393 Test2::API::test2_set_is_end(0);
395 # We leave this a global because it has to be localized and localizing
396 # hash keys is just asking for pain. Also, it was documented.
399 $self->{no_log_results} = $ENV{TEST_NO_LOG_RESULTS} ? 1 : 0
400 unless $params{singleton};
402 $self->{Original_Pid} = Test2::API::test2_in_preload() ? -1 : $$;
404 my $ctx = $self->ctx;
407 unless ($params{singleton}) {
414 my $meta = $ctx->hub->meta(__PACKAGE__, {});
418 Done_Testing => undef,
421 parent => $meta->{parent},
424 $self->{Exported_To} = undef unless $params{singleton};
426 $self->{Orig_Handles} ||= do {
427 my $format = $ctx->hub->format;
429 if ($format && $format->isa('Test2::Formatter::TAP')) {
430 $out = $format->handles;
435 $self->use_numbers(1);
436 $self->no_header(0) unless $params{singleton};
437 $self->no_ending(0) unless $params{singleton};
438 $self->reset_outputs;
447 no_plan => \&no_plan,
448 skip_all => \&skip_all,
449 tests => \&_plan_tests,
453 my( $self, $cmd, $arg ) = @_;
457 my $ctx = $self->ctx;
460 $ctx->throw("You tried to plan twice") if $hub->plan;
462 local $Level = $Level + 1;
464 if( my $method = $plan_cmds{$cmd} ) {
465 local $Level = $Level + 1;
466 $self->$method($arg);
469 my @args = grep { defined } ( $cmd, $arg );
470 $ctx->throw("plan() doesn't understand @args");
478 my($self, $arg) = @_;
480 my $ctx = $self->ctx;
483 local $Level = $Level + 1;
484 $self->expected_tests($arg);
486 elsif( !defined $arg ) {
487 $ctx->throw("Got an undefined number of tests");
490 $ctx->throw("You said to run 0 tests");
501 my $ctx = $self->ctx;
504 $self->croak("Number of tests must be a positive integer. You gave it '$max'")
505 unless $max =~ /^\+?\d+$/;
514 my $plan = $hub->plan;
515 return 0 unless $plan;
516 return 0 if $plan =~ m/\D/;
522 my($self, $arg) = @_;
524 my $ctx = $self->ctx;
526 if (defined $ctx->hub->plan) {
527 warn "Plan already set, no_plan() is a no-op, this will change to a hard failure in the future.";
532 $ctx->alert("no_plan takes no arguments") if $arg;
534 $ctx->hub->plan('NO PLAN');
541 my($self, $num_tests) = @_;
543 my $ctx = $self->ctx;
545 my $meta = $ctx->hub->meta(__PACKAGE__, {});
547 if ($meta->{Done_Testing}) {
548 my ($file, $line) = @{$meta->{Done_Testing}}[1,2];
549 local $ctx->hub->{ended}; # OMG This is awful.
550 $self->ok(0, "done_testing() was already called at $file line $line");
554 $meta->{Done_Testing} = [$ctx->trace->call];
556 my $plan = $ctx->hub->plan;
557 my $count = $ctx->hub->count;
559 # If done_testing() specified the number of tests, shut off no_plan
560 if( defined $num_tests ) {
561 $ctx->plan($num_tests) if !$plan || $plan eq 'NO PLAN';
563 elsif ($count && defined $num_tests && $count != $num_tests) {
564 $self->ok(0, "planned to run @{[ $self->expected_tests ]} but done_testing() expects $num_tests");
567 $num_tests = $self->current_test;
570 if( $self->expected_tests && $num_tests != $self->expected_tests ) {
571 $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
572 "but done_testing() expects $num_tests");
575 $ctx->plan($num_tests) if $ctx->hub->plan && $ctx->hub->plan eq 'NO PLAN';
577 $ctx->hub->finalize($ctx->trace, 1);
586 my $ctx = $self->ctx;
587 my $plan = $ctx->hub->plan;
590 return( $plan ) if $plan && $plan !~ m/\D/;
591 return('no_plan') if $plan && $plan eq 'NO PLAN';
597 my( $self, $reason ) = @_;
599 my $ctx = $self->ctx;
601 $ctx->hub->meta(__PACKAGE__, {})->{Skip_All} = $reason || 1;
603 # Work around old perl bug
607 while (my @call = caller($level++)) {
608 last unless @call && $call[0];
609 next unless $call[3] =~ m/::BEGIN$/;
614 die 'Label not found for "last T2_SUBTEST_WRAPPER"' if $begin && $ctx->hub->meta(__PACKAGE__, {})->{parent};
617 $ctx->plan(0, SKIP => $reason);
622 my( $self, $pack ) = @_;
624 if( defined $pack ) {
625 $self->{Exported_To} = $pack;
627 return $self->{Exported_To};
632 my( $self, $test, $name ) = @_;
634 my $ctx = $self->ctx;
636 # $test might contain an object which we don't want to accidentally
637 # store, so we turn it into a boolean.
638 $test = $test ? 1 : 0;
640 # In case $name is a string overloaded object, force it to stringify.
641 no warnings qw/uninitialized numeric/;
642 $name = "$name" if defined $name;
644 # Profiling showed that the regex here was a huge time waster, doing the
645 # numeric addition first cuts our profile time from ~300ms to ~50ms
646 $self->diag(<<" ERR") if 0 + $name && $name =~ /^[\d\s]+$/;
647 You named your test '$name'. You shouldn't use numbers for your test names.
650 use warnings qw/uninitialized numeric/;
652 my $trace = $ctx->{trace};
653 my $hub = $ctx->{hub};
660 (name => defined($name) ? $name : ''),
663 $hub->{_meta}->{+__PACKAGE__}->{Test_Results}[ $hub->{count} ] = $result unless $self->{no_log_results};
665 my $orig_name = $name;
668 my $subevents = delete $self->{subevents};
669 my $subtest_id = delete $self->{subtest_id};
670 my $subtest_buffered = delete $self->{subtest_buffered};
671 my $epkg = 'Test2::Event::Ok';
673 $epkg = 'Test2::Event::Subtest';
674 push @attrs => (subevents => $subevents, subtest_id => $subtest_id, buffered => $subtest_buffered);
678 trace => bless( {%$trace}, 'Test2::EventFacet::Trace'),
681 _meta => {'Test::Builder' => $result},
682 effective_pass => $test,
687 $self->_ok_debug($trace, $orig_name) unless($test);
695 my ($trace, $orig_name) = @_;
697 my $is_todo = defined($self->todo);
699 my $msg = $is_todo ? "Failed (TODO)" : "Failed";
701 my (undef, $file, $line) = $trace->call;
702 if (defined $orig_name) {
703 $self->diag(qq[ $msg test '$orig_name'\n at $file line $line.\n]);
706 $self->diag(qq[ $msg test at $file line $line.\n]);
712 local $Level = $Level + 1;
713 return $self->in_todo ? $self->todo_output : $self->failure_output;
717 my ($self, $type, $thing) = @_;
719 return unless ref $$thing;
720 return unless blessed($$thing) || scalar $self->_try(sub{ $$thing->isa('UNIVERSAL') });
725 my $string_meth = overload::Method( $$thing, $type ) || return;
726 $$thing = $$thing->$string_meth();
729 sub _unoverload_str {
732 $self->_unoverload( q[""], $_ ) for @_;
735 sub _unoverload_num {
738 $self->_unoverload( '0+', $_ ) for @_;
741 next unless $self->_is_dualvar($$val);
746 # This is a hack to detect a dualvar such as $!
748 my( $self, $val ) = @_;
750 # Objects are not dualvars.
751 return 0 if ref $val;
753 no warnings 'numeric';
754 my $numval = $val + 0;
755 return ($numval != 0 and $numval ne $val ? 1 : 0);
760 my( $self, $got, $expect, $name ) = @_;
762 my $ctx = $self->ctx;
764 local $Level = $Level + 1;
766 if( !defined $got || !defined $expect ) {
767 # undef only matches undef and nothing else
768 my $test = !defined $got && !defined $expect;
770 $self->ok( $test, $name );
771 $self->_is_diag( $got, 'eq', $expect ) unless $test;
776 release $ctx, $self->cmp_ok( $got, 'eq', $expect, $name );
781 my( $self, $got, $expect, $name ) = @_;
782 my $ctx = $self->ctx;
783 local $Level = $Level + 1;
785 if( !defined $got || !defined $expect ) {
786 # undef only matches undef and nothing else
787 my $test = !defined $got && !defined $expect;
789 $self->ok( $test, $name );
790 $self->_is_diag( $got, '==', $expect ) unless $test;
795 release $ctx, $self->cmp_ok( $got, '==', $expect, $name );
800 my( $self, $type, $val ) = @_;
802 if( defined $$val ) {
803 if( $type eq 'eq' or $type eq 'ne' ) {
804 # quote and force string context
808 # force numeric context
809 $self->_unoverload_num($val);
821 my( $self, $got, $type, $expect ) = @_;
823 $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
825 local $Level = $Level + 1;
826 return $self->diag(<<"DIAGNOSTIC");
834 my( $self, $got, $type ) = @_;
836 $self->_diag_fmt( $type, \$got );
838 local $Level = $Level + 1;
839 return $self->diag(<<"DIAGNOSTIC");
841 expected: anything else
847 my( $self, $got, $dont_expect, $name ) = @_;
848 my $ctx = $self->ctx;
849 local $Level = $Level + 1;
851 if( !defined $got || !defined $dont_expect ) {
852 # undef only matches undef and nothing else
853 my $test = defined $got || defined $dont_expect;
855 $self->ok( $test, $name );
856 $self->_isnt_diag( $got, 'ne' ) unless $test;
861 release $ctx, $self->cmp_ok( $got, 'ne', $dont_expect, $name );
865 my( $self, $got, $dont_expect, $name ) = @_;
866 my $ctx = $self->ctx;
867 local $Level = $Level + 1;
869 if( !defined $got || !defined $dont_expect ) {
870 # undef only matches undef and nothing else
871 my $test = defined $got || defined $dont_expect;
873 $self->ok( $test, $name );
874 $self->_isnt_diag( $got, '!=' ) unless $test;
879 release $ctx, $self->cmp_ok( $got, '!=', $dont_expect, $name );
884 my( $self, $thing, $regex, $name ) = @_;
885 my $ctx = $self->ctx;
887 local $Level = $Level + 1;
889 release $ctx, $self->_regex_ok( $thing, $regex, '=~', $name );
893 my( $self, $thing, $regex, $name ) = @_;
894 my $ctx = $self->ctx;
896 local $Level = $Level + 1;
898 release $ctx, $self->_regex_ok( $thing, $regex, '!~', $name );
902 my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
904 # Bad, these are not comparison operators. Should we include more?
905 my %cmp_ok_bl = map { ( $_, 1 ) } ( "=", "+=", ".=", "x=", "^=", "|=", "||=", "&&=", "...");
908 my( $self, $got, $type, $expect, $name ) = @_;
909 my $ctx = $self->ctx;
911 if ($cmp_ok_bl{$type}) {
912 $ctx->throw("$type is not a valid comparison operator in cmp_ok()");
918 ## no critic (BuiltinFunctions::ProhibitStringyEval)
920 local( $@, $!, $SIG{__DIE__} ); # isolate eval
922 my($pack, $file, $line) = $ctx->trace->call();
924 # This is so that warnings come out at the caller's level
926 #line $line "(eval in cmp_ok) $file"
927 \$test = (\$got $type \$expect);
932 local $Level = $Level + 1;
933 my $ok = $self->ok( $test, $name );
935 # Treat overloaded objects as numbers if we're asked to do a
936 # numeric comparison.
938 = $numeric_cmps{$type}
942 $self->diag(<<"END") unless $succ;
943 An error occurred while using $type:
944 ------------------------------------
946 ------------------------------------
950 $self->$unoverload( \$got, \$expect );
952 if( $type =~ /^(eq|==)$/ ) {
953 $self->_is_diag( $got, $type, $expect );
955 elsif( $type =~ /^(ne|!=)$/ ) {
957 my $eq = ($got eq $expect || $got == $expect)
959 (defined($got) xor defined($expect))
960 || (length($got) != length($expect))
965 $self->_cmp_diag( $got, $type, $expect );
968 $self->_isnt_diag( $got, $type );
972 $self->_cmp_diag( $got, $type, $expect );
975 return release $ctx, $ok;
979 my( $self, $got, $type, $expect ) = @_;
981 $got = defined $got ? "'$got'" : 'undef';
982 $expect = defined $expect ? "'$expect'" : 'undef';
984 local $Level = $Level + 1;
985 return $self->diag(<<"DIAGNOSTIC");
992 sub _caller_context {
995 my( $pack, $file, $line ) = $self->caller(1);
998 $code .= "#line $line $file\n" if defined $file and defined $line;
1005 my( $self, $reason ) = @_;
1007 my $ctx = $self->ctx;
1009 $self->{Bailed_Out} = 1;
1011 $ctx->bail($reason);
1017 *BAILOUT = \&BAIL_OUT;
1021 my( $self, $why, $name ) = @_;
1023 $name = '' unless defined $name;
1024 $self->_unoverload_str( \$why );
1026 my $ctx = $self->ctx;
1028 $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = {
1034 } unless $self->{no_log_results};
1036 $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
1037 $name =~ s{\n}{\n# }sg;
1038 $why =~ s{\n}{\n# }sg;
1040 my $tctx = $ctx->snapshot;
1041 $tctx->skip('', $why);
1043 return release $ctx, 1;
1048 my( $self, $why ) = @_;
1051 my $ctx = $self->ctx;
1053 $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = {
1057 type => 'todo_skip',
1059 } unless $self->{no_log_results};
1061 $why =~ s{\n}{\n# }sg;
1062 my $tctx = $ctx->snapshot;
1063 $tctx->send_event( 'Skip', todo => $why, todo_diag => 1, reason => $why, pass => 0);
1065 return release $ctx, 1;
1070 my( $self, $regex ) = @_;
1071 my $usable_regex = undef;
1073 return $usable_regex unless defined $regex;
1078 if( _is_qr($regex) ) {
1079 $usable_regex = $regex;
1081 # Check for '/foo/' or 'm,foo,'
1082 elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
1083 ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
1086 $usable_regex = length $opts ? "(?$opts)$re" : $re;
1089 return $usable_regex;
1095 # is_regexp() checks for regexes in a robust manner, say if they're
1097 return re::is_regexp($regex) if defined &re::is_regexp;
1098 return ref $regex eq 'Regexp';
1102 my( $self, $thing, $regex, $cmp, $name ) = @_;
1105 my $usable_regex = $self->maybe_regex($regex);
1106 unless( defined $usable_regex ) {
1107 local $Level = $Level + 1;
1108 $ok = $self->ok( 0, $name );
1109 $self->diag(" '$regex' doesn't look much like a regex to me.");
1115 my $context = $self->_caller_context;
1118 ## no critic (BuiltinFunctions::ProhibitStringyEval)
1120 local( $@, $!, $SIG{__DIE__} ); # isolate eval
1122 # No point in issuing an uninit warning, they'll see it in the diagnostics
1123 no warnings 'uninitialized';
1125 $test = eval $context . q{$test = $thing =~ /$usable_regex/ ? 1 : 0};
1128 $test = !$test if $cmp eq '!~';
1130 local $Level = $Level + 1;
1131 $ok = $self->ok( $test, $name );
1135 $thing = defined $thing ? "'$thing'" : 'undef';
1136 my $match = $cmp eq '=~' ? "doesn't match" : "matches";
1138 local $Level = $Level + 1;
1139 $self->diag( sprintf <<'DIAGNOSTIC', $thing, $match, $regex );
1152 my $maybe_fh = shift;
1153 return 0 unless defined $maybe_fh;
1155 return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
1156 return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
1158 return eval { $maybe_fh->isa("IO::Handle") } ||
1159 eval { tied($maybe_fh)->can('TIEHANDLE') };
1164 my( $self, $level ) = @_;
1166 if( defined $level ) {
1174 my( $self, $use_nums ) = @_;
1176 my $ctx = $self->ctx;
1177 my $format = $ctx->hub->format;
1178 unless ($format && $format->can('no_numbers') && $format->can('set_no_numbers')) {
1179 warn "The current formatter does not support 'use_numbers'" if $format;
1180 return release $ctx, 0;
1183 $format->set_no_numbers(!$use_nums) if defined $use_nums;
1185 return release $ctx, $format->no_numbers ? 0 : 1;
1189 for my $method (qw(no_header no_diag)) {
1190 my $set = "set_$method";
1192 my( $self, $no ) = @_;
1194 my $ctx = $self->ctx;
1195 my $format = $ctx->hub->format;
1196 unless ($format && $format->can($set)) {
1197 warn "The current formatter does not support '$method'" if $format;
1202 $format->$set($no) if defined $no;
1204 return release $ctx, $format->$method ? 1 : 0;
1207 no strict 'refs'; ## no critic
1213 my( $self, $no ) = @_;
1215 my $ctx = $self->ctx;
1217 $ctx->hub->set_no_ending($no) if defined $no;
1219 return release $ctx, $ctx->hub->no_ending;
1226 my $text = join '' => map {defined($_) ? $_ : 'undef'} @_;
1228 if (Test2::API::test2_in_preload()) {
1230 $text =~ s/^/# /msg;
1231 print STDERR $text, "\n";
1235 my $ctx = $self->ctx;
1246 my $text = join '' => map {defined($_) ? $_ : 'undef'} @_;
1248 if (Test2::API::test2_in_preload()) {
1250 $text =~ s/^/# /msg;
1251 print STDOUT $text, "\n";
1255 my $ctx = $self->ctx;
1266 require Data::Dumper;
1271 my $dumper = Data::Dumper->new( [$_] );
1272 $dumper->Indent(1)->Terse(1);
1273 $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
1282 my( $self, $fh ) = @_;
1284 my $ctx = $self->ctx;
1285 my $format = $ctx->hub->format;
1287 return unless $format && $format->isa('Test2::Formatter::TAP');
1289 $format->handles->[Test2::Formatter::TAP::OUT_STD()] = $self->_new_fh($fh)
1292 return $format->handles->[Test2::Formatter::TAP::OUT_STD()];
1295 sub failure_output {
1296 my( $self, $fh ) = @_;
1298 my $ctx = $self->ctx;
1299 my $format = $ctx->hub->format;
1301 return unless $format && $format->isa('Test2::Formatter::TAP');
1303 $format->handles->[Test2::Formatter::TAP::OUT_ERR()] = $self->_new_fh($fh)
1306 return $format->handles->[Test2::Formatter::TAP::OUT_ERR()];
1310 my( $self, $fh ) = @_;
1312 my $ctx = $self->ctx;
1313 my $format = $ctx->hub->format;
1315 return unless $format && $format->isa('Test::Builder::Formatter');
1317 $format->handles->[Test::Builder::Formatter::OUT_TODO()] = $self->_new_fh($fh)
1320 return $format->handles->[Test::Builder::Formatter::OUT_TODO()];
1325 my($file_or_fh) = shift;
1328 if( $self->is_fh($file_or_fh) ) {
1331 elsif( ref $file_or_fh eq 'SCALAR' ) {
1332 # Scalar refs as filehandles was added in 5.8.
1334 open $fh, ">>", $file_or_fh
1335 or $self->croak("Can't open scalar ref $file_or_fh: $!");
1337 # Emulate scalar ref filehandles with a tie.
1339 $fh = Test::Builder::IO::Scalar->new($file_or_fh)
1340 or $self->croak("Can't tie scalar ref $file_or_fh");
1344 open $fh, ">", $file_or_fh
1345 or $self->croak("Can't open test output log $file_or_fh: $!");
1354 my $old_fh = select $fh;
1365 my $ctx = $self->ctx;
1366 my $format = $ctx->hub->format;
1368 return unless $format && $format->isa('Test2::Formatter::TAP');
1369 $format->set_handles([@{$self->{Orig_Handles}}]) if $self->{Orig_Handles};
1377 my $ctx = $self->ctx;
1378 $ctx->alert(join "", @_);
1384 my $ctx = $self->ctx;
1385 $ctx->throw(join "", @_);
1391 my( $self, $num ) = @_;
1393 my $ctx = $self->ctx;
1394 my $hub = $ctx->hub;
1396 if( defined $num ) {
1397 $hub->set_count($num);
1399 unless ($self->{no_log_results}) {
1400 # If the test counter is being pushed forward fill in the details.
1401 my $test_results = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results};
1402 if ($num > @$test_results) {
1403 my $start = @$test_results ? @$test_results : 0;
1404 for ($start .. $num - 1) {
1405 $test_results->[$_] = {
1408 reason => 'incrementing test number',
1414 # If backward, wipe history. Its their funeral.
1415 elsif ($num < @$test_results) {
1416 $#{$test_results} = $num - 1;
1420 return release $ctx, $hub->count;
1427 my $ctx = $self->ctx;
1428 my $hub = $ctx->hub;
1432 $hub->set_failed(0) if $bool;
1433 $hub->is_passing($bool);
1436 return release $ctx, $hub->is_passing;
1443 return if $self->{no_log_results};
1445 my $ctx = $self->ctx;
1446 my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results};
1448 return map { $_ ? $_->{'ok'} : () } @$data;
1455 return if $self->{no_log_results};
1457 my $ctx = $self->ctx;
1458 my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results};
1465 my( $self, $pack, $set, $new_value ) = @_;
1467 my $ctx = $self->ctx;
1469 $pack ||= $ctx->trace->package || $self->exported_to;
1472 return unless $pack;
1474 no strict 'refs'; ## no critic
1476 my $old_value = ${ $pack . '::TODO' };
1477 $set and ${ $pack . '::TODO' } = $new_value;
1482 my( $self, $pack ) = @_;
1484 local $Level = $Level + 1;
1485 my $ctx = $self->ctx;
1488 my $meta = $ctx->hub->meta(__PACKAGE__, {todo => []})->{todo};
1489 return $meta->[-1]->[1] if $meta && @$meta;
1491 $pack ||= $ctx->trace->package;
1493 return unless $pack;
1495 no strict 'refs'; ## no critic
1497 return ${ $pack . '::TODO' };
1503 local $Level = $Level + 1;
1504 my $ctx = $self->ctx;
1507 my $meta = $ctx->hub->meta(__PACKAGE__, {todo => []})->{todo};
1508 return 1 if $meta && @$meta;
1510 my $pack = $ctx->trace->package || return 0;
1512 no strict 'refs'; ## no critic
1514 my $todo = ${ $pack . '::TODO' };
1516 return 0 unless defined $todo;
1517 return 0 if "$todo" eq '';
1523 my $message = @_ ? shift : '';
1525 my $ctx = $self->ctx;
1527 my $hub = $ctx->hub;
1528 my $filter = $hub->pre_filter(sub {
1529 my ($active_hub, $e) = @_;
1531 # Turn a diag into a todo diag
1532 return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag';
1535 if ($hub == $active_hub && $e->isa('Test2::Event::Ok')) {
1536 $e->set_todo($message);
1537 $e->set_effective_pass(1);
1539 if (my $result = $e->get_meta(__PACKAGE__)) {
1540 $result->{reason} ||= $message;
1541 $result->{type} ||= 'todo';
1549 push @{$ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}} => [$filter, $message];
1559 my $ctx = $self->ctx;
1561 my $set = pop @{$ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}};
1563 $ctx->throw('todo_end() called without todo_start()') unless $set;
1565 $ctx->hub->pre_unfilter($set->[0]);
1573 sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
1576 my $ctx = $self->ctx;
1578 my $trace = $ctx->trace;
1580 return wantarray ? $trace->call : $trace->package;
1585 my( $self, $code, %opts ) = @_;
1590 local $!; # eval can mess up $!
1591 local $@; # don't set $@ in the test
1592 local $SIG{__DIE__}; # don't trip an outside DIE handler.
1593 $return = eval { $code->() };
1597 die $error if $error and $opts{die_on_fail};
1599 return wantarray ? ( $return, $error ) : $return;
1604 my ($ctx, $real_exit_code, $new) = @_;
1607 my $octx = $self->ctx;
1608 $ctx = $octx->snapshot;
1612 return if $ctx->hub->no_ending;
1613 return if $ctx->hub->meta(__PACKAGE__, {})->{Ending}++;
1615 # Don't bother with an ending if this is a forked copy. Only the parent
1616 # should do the ending.
1617 return unless $self->{Original_Pid} == $$;
1619 my $hub = $ctx->hub;
1620 return if $hub->bailed_out;
1622 my $plan = $hub->plan;
1623 my $count = $hub->count;
1624 my $failed = $hub->failed;
1625 my $passed = $hub->is_passing;
1626 return unless $plan || $count || $failed;
1628 # Ran tests but never declared a plan or hit done_testing
1629 if( !$hub->plan and $hub->count ) {
1630 $self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
1632 if($real_exit_code) {
1633 $self->diag(<<"FAIL");
1634 Looks like your test exited with $real_exit_code just after $count.
1636 $$new ||= $real_exit_code;
1640 # But if the tests ran, handle exit code.
1642 my $exit_code = $failed <= 254 ? $failed : 254;
1643 $$new ||= $exit_code;
1651 if ($real_exit_code && !$count) {
1652 $self->diag("Looks like your test exited with $real_exit_code before it could output anything.");
1653 $$new ||= $real_exit_code;
1657 return if $plan && "$plan" eq 'SKIP';
1660 $self->diag('No tests run!');
1665 if ($real_exit_code) {
1666 $self->diag(<<"FAIL");
1667 Looks like your test exited with $real_exit_code just after $count.
1669 $$new ||= $real_exit_code;
1673 if ($plan eq 'NO PLAN') {
1674 $ctx->plan( $count );
1678 # Figure out if we passed or failed and print helpful messages.
1679 my $num_extra = $count - $plan;
1681 if ($num_extra != 0) {
1682 my $s = $plan == 1 ? '' : 's';
1683 $self->diag(<<"FAIL");
1684 Looks like you planned $plan test$s but ran $count.
1689 my $s = $failed == 1 ? '' : 's';
1691 my $qualifier = $num_extra == 0 ? '' : ' run';
1693 $self->diag(<<"FAIL");
1694 Looks like you failed $failed test$s of $count$qualifier.
1698 if (!$passed && !$failed && $count && !$num_extra) {
1699 $ctx->diag(<<"FAIL");
1700 All assertions passed, but errors were encountered.
1706 $exit_code = $failed <= 254 ? $failed : 254;
1708 elsif ($num_extra != 0) {
1715 $$new ||= $exit_code;
1719 # Some things used this even though it was private... I am looking at you
1720 # Test::Builder::Prefix...
1721 sub _print_comment {
1722 my( $self, $fh, @msgs ) = @_;
1724 return if $self->no_diag;
1725 return unless @msgs;
1727 # Prevent printing headers when compiling (i.e. -c)
1730 # Smash args together like print does.
1731 # Convert undef to 'undef' so its readable.
1732 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1734 # Escape the beginning, _print will take care of the rest.
1737 local( $\, $", $, ) = ( undef, ' ', '' );
1743 # This is used by Test::SharedFork to turn on IPC after the fact. Not
1744 # documenting because I do not want it used. The method name is borrowed from
1746 # Once Test2 stuff goes stable this method will be removed and Test::SharedFork
1747 # will be made smarter.
1748 sub coordinate_forks {
1756 Test2::API::test2_ipc_enable_polling();
1757 Test2::API::test2_load();
1758 my $ipc = Test2::IPC::apply_ipc($self->{Stack});
1759 $ipc->set_no_fatal(1);
1760 Test2::API::test2_no_wait(1);
1761 Test2::API::test2_ipc_enable_shm();
1764 sub no_log_results { $_[0]->{no_log_results} = 1 }
1772 Test::Builder - Backend for building test libraries
1776 package My::Test::Module;
1777 use base 'Test::Builder::Module';
1779 my $CLASS = __PACKAGE__;
1782 my($test, $name) = @_;
1783 my $tb = $CLASS->builder;
1785 $tb->ok($test, $name);
1791 L<Test::Simple> and L<Test::More> have proven to be popular testing modules,
1792 but they're not always flexible enough. Test::Builder provides a
1793 building block upon which to write your own test libraries I<which can
1802 my $Test = Test::Builder->new;
1804 Returns a Test::Builder object representing the current state of the
1807 Since you only run one test per program C<new> always returns the same
1808 Test::Builder object. No matter how many times you call C<new()>, you're
1809 getting the same object. This is called a singleton. This is done so that
1810 multiple modules share such global information as the test counter and
1811 where test output is going.
1813 If you want a completely new Test::Builder object different from the
1814 singleton, use C<create>.
1818 my $Test = Test::Builder->create;
1820 Ok, so there can be more than one Test::Builder object and this is how
1821 you get it. You might use this instead of C<new()> if you're testing
1822 a Test::Builder based module, but otherwise you probably want C<new>.
1824 B<NOTE>: the implementation is not complete. C<level>, for example, is still
1825 shared by B<all> Test::Builder objects, even ones created using this method.
1826 Also, the method name may change in the future.
1830 $builder->subtest($name, \&subtests, @args);
1832 See documentation of C<subtest> in Test::More.
1834 C<subtest> also, and optionally, accepts arguments which will be passed to the
1839 diag $builder->name;
1841 Returns the name of the current builder. Top level builders default to C<$0>
1842 (the name of the executable). Child builders are named via the C<child>
1843 method. If no name is supplied, will be named "Child of $parent->name".
1849 Reinitializes the Test::Builder singleton to its original state.
1850 Mostly useful for tests run in persistent environments where the same
1851 test might be run multiple times in the same process.
1855 =head2 Setting up tests
1857 These methods are for setting up tests and declaring how many there
1858 are. You usually only want to call one of these methods.
1864 $Test->plan('no_plan');
1865 $Test->plan( skip_all => $reason );
1866 $Test->plan( tests => $num_tests );
1868 A convenient way to set up your tests. Call this and Test::Builder
1869 will print the appropriate headers and take the appropriate actions.
1871 If you call C<plan()>, don't call any of the other methods below.
1873 =item B<expected_tests>
1875 my $max = $Test->expected_tests;
1876 $Test->expected_tests($max);
1878 Gets/sets the number of tests we expect this test to run and prints out
1879 the appropriate headers.
1886 Declares that this test will run an indeterminate number of tests.
1889 =item B<done_testing>
1891 $Test->done_testing();
1892 $Test->done_testing($num_tests);
1894 Declares that you are done testing, no more tests will be run after this point.
1896 If a plan has not yet been output, it will do so.
1898 $num_tests is the number of tests you planned to run. If a numbered
1899 plan was already declared, and if this contradicts, a failing test
1900 will be run to reflect the planning mistake. If C<no_plan> was declared,
1903 If C<done_testing()> is called twice, the second call will issue a
1906 If C<$num_tests> is omitted, the number of tests run will be used, like
1909 C<done_testing()> is, in effect, used when you'd want to use C<no_plan>, but
1910 safer. You'd use it like so:
1912 $Test->ok($a == $b);
1913 $Test->done_testing();
1915 Or to plan a variable number of tests:
1917 for my $test (@tests) {
1920 $Test->done_testing(scalar @tests);
1925 $plan = $Test->has_plan
1927 Find out whether a plan has been defined. C<$plan> is either C<undef> (no plan
1928 has been set), C<no_plan> (indeterminate # of tests) or an integer (the number
1934 $Test->skip_all($reason);
1936 Skips all the tests, using the given C<$reason>. Exits immediately with 0.
1938 =item B<exported_to>
1940 my $pack = $Test->exported_to;
1941 $Test->exported_to($pack);
1943 Tells Test::Builder what package you exported your functions to.
1945 This method isn't terribly useful since modules which share the same
1946 Test::Builder object might get exported to different packages and only
1947 the last one will be honored.
1951 =head2 Running tests
1953 These actually run the tests, analogous to the functions in Test::More.
1955 They all return true if the test passed, false if the test failed.
1957 C<$name> is always optional.
1963 $Test->ok($test, $name);
1965 Your basic test. Pass if C<$test> is true, fail if $test is false. Just
1966 like Test::Simple's C<ok()>.
1970 $Test->is_eq($got, $expected, $name);
1972 Like Test::More's C<is()>. Checks if C<$got eq $expected>. This is the
1975 C<undef> only ever matches another C<undef>.
1979 $Test->is_num($got, $expected, $name);
1981 Like Test::More's C<is()>. Checks if C<$got == $expected>. This is the
1984 C<undef> only ever matches another C<undef>.
1988 $Test->isnt_eq($got, $dont_expect, $name);
1990 Like L<Test::More>'s C<isnt()>. Checks if C<$got ne $dont_expect>. This is
1995 $Test->isnt_num($got, $dont_expect, $name);
1997 Like L<Test::More>'s C<isnt()>. Checks if C<$got ne $dont_expect>. This is
1998 the numeric version.
2002 $Test->like($thing, qr/$regex/, $name);
2003 $Test->like($thing, '/$regex/', $name);
2005 Like L<Test::More>'s C<like()>. Checks if $thing matches the given C<$regex>.
2009 $Test->unlike($thing, qr/$regex/, $name);
2010 $Test->unlike($thing, '/$regex/', $name);
2012 Like L<Test::More>'s C<unlike()>. Checks if $thing B<does not match> the
2017 $Test->cmp_ok($thing, $type, $that, $name);
2019 Works just like L<Test::More>'s C<cmp_ok()>.
2021 $Test->cmp_ok($big_num, '!=', $other_big_num);
2025 =head2 Other Testing Methods
2027 These are methods which are used in the course of writing a test but are not themselves tests.
2033 $Test->BAIL_OUT($reason);
2035 Indicates to the L<Test::Harness> that things are going so badly all
2036 testing should terminate. This includes running any additional test
2039 It will exit with 255.
2042 BAIL_OUT() used to be BAILOUT()
2049 Skips the current test, reporting C<$why>.
2054 $Test->todo_skip($why);
2056 Like C<skip()>, only it will declare the test as failing and TODO. Similar
2059 print "not ok $tnum # TODO $why\n";
2061 =begin _unimplemented
2066 $Test->skip_rest($reason);
2068 Like C<skip()>, only it skips all the rest of the tests you plan to run
2069 and terminates the test.
2071 If you're running under C<no_plan>, it skips once and terminates the
2079 =head2 Test building utility methods
2081 These methods are useful when writing your own test methods.
2085 =item B<maybe_regex>
2087 $Test->maybe_regex(qr/$regex/);
2088 $Test->maybe_regex('/$regex/');
2090 This method used to be useful back when Test::Builder worked on Perls
2091 before 5.6 which didn't have qr//. Now its pretty useless.
2093 Convenience method for building testing functions that take regular
2094 expressions as arguments.
2096 Takes a quoted regular expression produced by C<qr//>, or a string
2097 representing a regular expression.
2099 Returns a Perl value which may be used instead of the corresponding
2100 regular expression, or C<undef> if its argument is not recognized.
2102 For example, a version of C<like()>, sans the useful diagnostic messages,
2103 could be written as:
2106 my ($self, $thing, $regex, $name) = @_;
2107 my $usable_regex = $self->maybe_regex($regex);
2108 die "expecting regex, found '$regex'\n"
2109 unless $usable_regex;
2110 $self->ok($thing =~ m/$usable_regex/, $name);
2116 my $is_fh = $Test->is_fh($thing);
2118 Determines if the given C<$thing> can be used as a filehandle.
2133 $Test->level($how_high);
2135 How far up the call stack should C<$Test> look when reporting where the
2140 Setting C<$Test::Builder::Level> overrides. This is typically useful
2146 local $Test::Builder::Level = $Test::Builder::Level + 1;
2150 To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant.
2152 =item B<use_numbers>
2154 $Test->use_numbers($on_or_off);
2156 Whether or not the test should output numbers. That is, this if true:
2168 Most useful when you can't depend on the test output order, such as
2169 when threads or forking is involved.
2175 $Test->no_diag($no_diag);
2177 If set true no diagnostics will be printed. This includes calls to
2182 $Test->no_ending($no_ending);
2184 Normally, Test::Builder does some extra diagnostics when the test
2185 ends. It also changes the exit code as described below.
2187 If this is true, none of that will be done.
2191 $Test->no_header($no_header);
2193 If set to true, no "1..N" header will be printed.
2199 Controlling where the test output goes.
2201 It's ok for your test to change where STDOUT and STDERR point to,
2202 Test::Builder's default output settings will not be affected.
2210 Prints out the given C<@msgs>. Like C<print>, arguments are simply
2213 Normally, it uses the C<failure_output()> handle, but if this is for a
2214 TODO test, the C<todo_output()> handle is used.
2216 Output will be indented and marked with a # so as not to interfere
2217 with test output. A newline will be put on the end if there isn't one
2220 We encourage using this rather than calling print directly.
2222 Returns false. Why? Because C<diag()> is often used in conjunction with
2223 a failing test (C<ok() || diag()>) it "passes through" the failure.
2225 return ok(...) || diag(...);
2228 Mark Fowler <mark@twoshortplanks.com>
2234 Like C<diag()>, but it prints to the C<output()> handle so it will not
2235 normally be seen by the user except in verbose mode.
2239 my @dump = $Test->explain(@msgs);
2241 Will dump the contents of any references in a human readable format.
2242 Handy for things like...
2244 is_deeply($have, $want) || diag explain $have;
2248 is_deeply($have, $want) || note explain $have;
2252 =item B<failure_output>
2254 =item B<todo_output>
2256 my $filehandle = $Test->output;
2257 $Test->output($filehandle);
2258 $Test->output($filename);
2259 $Test->output(\$scalar);
2261 These methods control where Test::Builder will print its output.
2262 They take either an open C<$filehandle>, a C<$filename> to open and write to
2263 or a C<$scalar> reference to append to. It will always return a C<$filehandle>.
2265 B<output> is where normal "ok/not ok" test output goes.
2269 B<failure_output> is where diagnostic output on test failures and
2270 C<diag()> goes. It is normally not read by Test::Harness and instead is
2271 displayed to the user.
2275 C<todo_output> is used instead of C<failure_output()> for the
2276 diagnostics of a failing TODO test. These will not be seen by the
2285 Resets all the output filehandles back to their defaults.
2289 $tb->carp(@message);
2291 Warns with C<@message> but the message will appear to come from the
2292 point where the original test function was called (C<< $tb->caller >>).
2296 $tb->croak(@message);
2298 Dies with C<@message> but the message will appear to come from the
2299 point where the original test function was called (C<< $tb->caller >>).
2305 =head2 Test Status and Info
2309 =item B<no_log_results>
2311 This will turn off result long-term storage. Calling this method will make
2312 C<details> and C<summary> useless. You may want to use this if you are running
2313 enough tests to fill up all available memory.
2315 Test::Builder->new->no_log_results();
2317 There is no way to turn it back on.
2319 =item B<current_test>
2321 my $curr_test = $Test->current_test;
2322 $Test->current_test($num);
2324 Gets/sets the current test number we're on. You usually shouldn't
2327 If set forward, the details of the missing tests are filled in as 'unknown'.
2328 if set backward, the details of the intervening tests are deleted. You
2329 can erase history if you really want to.
2334 my $ok = $builder->is_passing;
2336 Indicates if the test suite is currently passing.
2338 More formally, it will be false if anything has happened which makes
2339 it impossible for the test suite to pass. True otherwise.
2341 For example, if no tests have run C<is_passing()> will be true because
2342 even though a suite with no tests is a failure you can add a passing
2343 test to it and start passing.
2345 Don't think about it too much.
2350 my @tests = $Test->summary;
2352 A simple summary of the tests so far. True for pass, false for fail.
2353 This is a logical pass/fail, so todos are passes.
2355 Of course, test #1 is $tests[0], etc...
2360 my @tests = $Test->details;
2362 Like C<summary()>, but with a lot more detail.
2364 $tests[$test_num - 1] =
2365 { 'ok' => is the test considered a pass?
2366 actual_ok => did it literally say 'ok'?
2367 name => name of the test (if any)
2368 type => type of test (if any, see below).
2369 reason => reason for the above (if any)
2372 'ok' is true if Test::Harness will consider the test to be a pass.
2374 'actual_ok' is a reflection of whether or not the test literally
2375 printed 'ok' or 'not ok'. This is for examining the result of 'todo'
2378 'name' is the name of the test.
2380 'type' indicates if it was a special test. Normal tests have a type
2381 of ''. Type can be one of the following:
2385 todo_skip see todo_skip()
2388 Sometimes the Test::Builder test counter is incremented without it
2389 printing any test output, for example, when C<current_test()> is changed.
2390 In these cases, Test::Builder doesn't know the result of the test, so
2391 its type is 'unknown'. These details for these tests are filled in.
2392 They are considered ok, but the name and actual_ok is left C<undef>.
2394 For example "not ok 23 - hole count # TODO insufficient donuts" would
2395 result in this structure:
2397 $tests[22] = # 23 - 1, since arrays start from 0.
2398 { ok => 1, # logically, the test passed since its todo
2399 actual_ok => 0, # in absolute terms, it failed
2400 name => 'hole count',
2402 reason => 'insufficient donuts'
2408 my $todo_reason = $Test->todo;
2409 my $todo_reason = $Test->todo($pack);
2411 If the current tests are considered "TODO" it will return the reason,
2412 if any. This reason can come from a C<$TODO> variable or the last call
2415 Since a TODO test does not need a reason, this function can return an
2416 empty string even when inside a TODO block. Use C<< $Test->in_todo >>
2417 to determine if you are currently inside a TODO block.
2419 C<todo()> is about finding the right package to look for C<$TODO> in. It's
2420 pretty good at guessing the right package to look at. It first looks for
2421 the caller based on C<$Level + 1>, since C<todo()> is usually called inside
2422 a test function. As a last resort it will use C<exported_to()>.
2424 Sometimes there is some confusion about where C<todo()> should be looking
2425 for the C<$TODO> variable. If you want to be sure, tell it explicitly
2430 my $todo_reason = $Test->find_TODO();
2431 my $todo_reason = $Test->find_TODO($pack);
2433 Like C<todo()> but only returns the value of C<$TODO> ignoring
2436 Can also be used to set C<$TODO> to a new value while returning the
2439 my $old_reason = $Test->find_TODO($pack, 1, $new_reason);
2443 my $in_todo = $Test->in_todo;
2445 Returns true if the test is currently inside a TODO block.
2449 $Test->todo_start();
2450 $Test->todo_start($message);
2452 This method allows you declare all subsequent tests as TODO tests, up until
2453 the C<todo_end> method has been called.
2455 The C<TODO:> and C<$TODO> syntax is generally pretty good about figuring out
2456 whether or not we're in a TODO test. However, often we find that this is not
2457 possible to determine (such as when we want to use C<$TODO> but
2458 the tests are being executed in other packages which can't be inferred
2461 Note that you can use this to nest "todo" tests
2463 $Test->todo_start('working on this');
2465 $Test->todo_start('working on that');
2470 This is generally not recommended, but large testing systems often have weird
2473 We've tried to make this also work with the TODO: syntax, but it's not
2474 guaranteed and its use is also discouraged:
2477 local $TODO = 'We have work to do!';
2478 $Test->todo_start('working on this');
2480 $Test->todo_start('working on that');
2486 Pick one style or another of "TODO" to be on the safe side.
2493 Stops running tests as "TODO" tests. This method is fatal if called without a
2494 preceding C<todo_start> method call.
2498 my $package = $Test->caller;
2499 my($pack, $file, $line) = $Test->caller;
2500 my($pack, $file, $line) = $Test->caller($height);
2502 Like the normal C<caller()>, except it reports according to your C<level()>.
2504 C<$height> will be added to the C<level()>.
2506 If C<caller()> winds up off the top of the stack it report the highest context.
2512 If all your tests passed, Test::Builder will exit with zero (which is
2513 normal). If anything failed it will exit with how many failed. If
2514 you run less (or more) tests than you planned, the missing (or extras)
2515 will be considered failures. If no tests were ever run Test::Builder
2516 will throw a warning and exit with 255. If the test died, even after
2517 having successfully completed all its tests, it will still be
2518 considered a failure and will exit with 255.
2520 So the exit codes are...
2522 0 all tests successful
2523 255 test died or all passed but wrong # of tests run
2524 any other number how many failed (including missing or extras)
2526 If you fail more than 254 tests, it will be reported as 254.
2530 In perl 5.8.1 and later, Test::Builder is thread-safe. The test number is
2531 shared by all threads. This means if one thread sets the test number using
2532 C<current_test()> they will all be effected.
2534 While versions earlier than 5.8.1 had threads they contain too many
2537 Test::Builder is only thread-aware if threads.pm is loaded I<before>
2542 An informative hash, accessible via C<details()>, is stored for each
2543 test you perform. So memory usage will scale linearly with each test
2544 run. Although this is not a problem for most test suites, it can
2545 become an issue if you do large (hundred thousands to million)
2546 combinatorics tests in the same run.
2548 In such cases, you are advised to either split the test file into smaller
2549 ones, or use a reverse approach, doing "normal" (code) compares and
2550 triggering C<fail()> should anything go unexpected.
2552 Future versions of Test::Builder will have a way to turn history off.
2557 CPAN can provide the best examples. L<Test::Simple>, L<Test::More>,
2558 L<Test::Exception> and L<Test::Differences> all use Test::Builder.
2562 L<Test::Simple>, L<Test::More>, L<Test::Harness>
2566 Original code by chromatic, maintained by Michael G Schwern
2567 E<lt>schwern@pobox.comE<gt>
2573 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
2579 Copyright 2002-2008 by chromatic E<lt>chromatic@wgz.orgE<gt> and
2580 Michael G Schwern E<lt>schwern@pobox.comE<gt>.
2582 This program is free software; you can redistribute it and/or
2583 modify it under the same terms as Perl itself.
2585 See F<http://www.perl.com/perl/misc/Artistic.html>