package Test::Builder;
-use 5.008001;
+use 5.006;
use strict;
use warnings;
-our $VERSION = '1.301001_079';
-$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
-
-
-use Test::Stream 1.301001 qw/ -internal STATE_LEGACY STATE_PLAN STATE_COUNT /;
-use Test::Stream::Toolset;
-use Test::Stream::Context;
-use Test::Stream::Carp qw/confess/;
-use Test::Stream::Meta qw/MODERN/;
-
-use Test::Stream::Util qw/try protect unoverload_str is_regex/;
-use Scalar::Util qw/blessed reftype/;
-
-use Test::More::Tools;
+our $VERSION = '1.302173';
BEGIN {
- my $meta = Test::Stream::Meta->is_tester('main');
- Test::Stream->shared->set_use_legacy(1)
- unless $meta && $meta->[MODERN];
+ if( $] < 5.008 ) {
+ require Test::Builder::IO::Scalar;
+ }
}
-# The mostly-singleton, and other package vars.
-our $Test = Test::Builder->new;
-our $_ORIG_Test = $Test;
-our $Level = 1;
+use Scalar::Util qw/blessed reftype weaken/;
-sub ctx {
- my $self = shift || die "No self in context";
- my ($add) = @_;
- my $ctx = Test::Stream::Context::context(2 + ($add || 0), $self->{stream});
- if (defined $self->{Todo}) {
- $ctx->set_in_todo(1);
- $ctx->set_todo($self->{Todo});
- $ctx->set_diag_todo(1);
+use Test2::Util qw/USE_THREADS try get_tid/;
+use Test2::API qw/context release/;
+# Make Test::Builder thread-safe for ithreads.
+BEGIN {
+ warn "Test::Builder was loaded after Test2 initialization, this is not recommended."
+ if Test2::API::test2_init_done() || Test2::API::test2_load_done();
+
+ if (USE_THREADS && ! Test2::API::test2_ipc_disabled()) {
+ require Test2::IPC;
+ require Test2::IPC::Driver::Files;
+ Test2::IPC::Driver::Files->import;
+ Test2::API::test2_ipc_enable_polling();
+ Test2::API::test2_no_wait(1);
}
- return $ctx;
}
-sub stream {
- my $self = shift;
- return $self->{stream} || Test::Stream->shared;
-}
+use Test2::Event::Subtest;
+use Test2::Hub::Subtest;
-sub depth { $_[0]->{depth} || 0 }
+use Test::Builder::Formatter;
+use Test::Builder::TodoDiag;
-# This is only for unit tests at this point.
-sub _ending {
+our $Level = 1;
+our $Test = $ENV{TB_NO_EARLY_INIT} ? undef : Test::Builder->new;
+
+sub _add_ts_hooks {
my $self = shift;
- my ($ctx) = @_;
- require Test::Stream::ExitMagic;
- $self->{stream}->set_no_ending(0);
- Test::Stream::ExitMagic->new->do_magic($self->{stream}, $ctx);
-}
-
-my %WARNED;
-our $CTX;
-our %ORIG = (
- ok => \&ok,
- diag => \&diag,
- note => \¬e,
- plan => \&plan,
- done_testing => \&done_testing,
-);
-sub WARN_OF_OVERRIDE {
- my ($sub, $ctx) = @_;
+ my $hub = $self->{Stack}->top;
- return unless $ctx->modern;
- my $old = $ORIG{$sub};
- # Use package instead of self, we want replaced subs, not subclass overrides.
- my $new = __PACKAGE__->can($sub);
+ # Take a reference to the hash key, we do this to avoid closing over $self
+ # which is the singleton. We use a reference because the value could change
+ # in rare cases.
+ my $epkgr = \$self->{Exported_To};
- return if $new == $old;
+ #$hub->add_context_aquire(sub {$_[0]->{level} += $Level - 1});
- require B;
- my $o = B::svref_2object($new);
- my $gv = $o->GV;
- my $st = $o->START;
- my $name = $gv->NAME;
- my $pkg = $gv->STASH->NAME;
- my $line = $st->line;
- my $file = $st->file;
+ $hub->pre_filter(sub {
+ my ($active_hub, $e) = @_;
- warn <<" EOT" unless $WARNED{"$pkg $name $file $line"}++;
+ my $epkg = $$epkgr;
+ my $cpkg = $e->{trace} ? $e->{trace}->{frame}->[0] : undef;
-*******************************************************************************
-Something monkeypatched Test::Builder::$sub()!
-The new sub is '$pkg\::$name' defined in $file around line $line.
-In the near future monkeypatching Test::Builder::ok() will no longer work
-as expected.
-*******************************************************************************
- EOT
-}
+ no strict 'refs';
+ no warnings 'once';
+ my $todo;
+ $todo = ${"$cpkg\::TODO"} if $cpkg;
+ $todo = ${"$epkg\::TODO"} if $epkg && !$todo;
+
+ return $e unless defined($todo);
+ return $e unless length($todo);
+ # Turn a diag into a todo diag
+ return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag';
-####################
-# {{{ Constructors #
-####################
+ $e->set_todo($todo) if $e->can('set_todo');
+ $e->add_amnesty({tag => 'TODO', details => $todo});
+
+ # Set todo on ok's
+ if ($e->isa('Test2::Event::Ok')) {
+ $e->set_effective_pass(1);
+
+ if (my $result = $e->get_meta(__PACKAGE__)) {
+ $result->{reason} ||= $todo;
+ $result->{type} ||= 'todo';
+ $result->{ok} = 1;
+ }
+ }
+
+ return $e;
+ }, inherit => 1);
+}
+
+{
+ no warnings;
+ INIT {
+ use warnings;
+ Test2::API::test2_load() unless Test2::API::test2_in_preload();
+ }
+}
sub new {
- my $class = shift;
- my %params = @_;
- $Test ||= $class->create(shared_stream => 1);
+ my($class) = shift;
+ unless($Test) {
+ $Test = $class->create(singleton => 1);
+
+ Test2::API::test2_add_callback_post_load(
+ sub {
+ $Test->{Original_Pid} = $$ if !$Test->{Original_Pid} || $Test->{Original_Pid} == 0;
+ $Test->reset(singleton => 1);
+ $Test->_add_ts_hooks;
+ }
+ );
+
+ # Non-TB tools normally expect 0 added to the level. $Level is normally 1. So
+ # we only want the level to change if $Level != 1.
+ # TB->ctx compensates for this later.
+ Test2::API::test2_add_callback_context_aquire(sub { $_[0]->{level} += $Level - 1 });
+ Test2::API::test2_add_callback_exit(sub { $Test->_ending(@_) });
+
+ Test2::API::test2_ipc()->set_no_fatal(1) if Test2::API::test2_has_ipc();
+ }
return $Test;
}
sub create {
- my $class = shift;
+ my $class = shift;
my %params = @_;
my $self = bless {}, $class;
- $self->reset(%params);
+ if ($params{singleton}) {
+ $self->{Stack} = Test2::API::test2_stack();
+ }
+ else {
+ $self->{Stack} = Test2::API::Stack->new;
+ $self->{Stack}->new_hub(
+ formatter => Test::Builder::Formatter->new,
+ ipc => Test2::API::test2_ipc(),
+ );
+
+ $self->reset(%params);
+ $self->_add_ts_hooks;
+ }
return $self;
}
-# Copy an object, currently a shallow.
-# This does *not* bless the destination. This keeps the destructor from
-# firing when we're just storing a copy of the object to restore later.
-sub _copy {
- my ($src, $dest) = @_;
- %$dest = %$src;
- return;
-}
+sub ctx {
+ my $self = shift;
+ context(
+ # 1 for our frame, another for the -1 off of $Level in our hook at the top.
+ level => 2,
+ fudge => 1,
+ stack => $self->{Stack},
+ hub => $self->{Hub},
+ wrapped => 1,
+ @_
+ );
+}
+
+sub parent {
+ my $self = shift;
+ my $ctx = $self->ctx;
+ my $chub = $self->{Hub} || $ctx->hub;
+ $ctx->release;
-####################
-# }}} Constructors #
-####################
+ my $meta = $chub->meta(__PACKAGE__, {});
+ my $parent = $meta->{parent};
-#############################
-# {{{ Children and subtests #
-#############################
+ return undef unless $parent;
-sub subtest {
- my $self = shift;
- my $ctx = $self->ctx();
- require Test::Stream::Subtest;
- return Test::Stream::Subtest::subtest(@_);
+ return bless {
+ Original_Pid => $$,
+ Stack => $self->{Stack},
+ Hub => $parent,
+ }, blessed($self);
}
sub child {
my( $self, $name ) = @_;
+ $name ||= "Child of " . $self->name;
my $ctx = $self->ctx;
- if ($self->{child}) {
- my $cname = $self->{child}->{Name};
- $ctx->throw("You already have a child named ($cname) running");
- }
+ my $parent = $ctx->hub;
+ my $pmeta = $parent->meta(__PACKAGE__, {});
+ $self->croak("You already have a child named ($pmeta->{child}) running")
+ if $pmeta->{child};
- $name ||= "Child of " . $self->{Name};
- $ctx->child('push', $name, 1);
+ $pmeta->{child} = $name;
- my $stream = $self->{stream} || Test::Stream->shared;
+ # Clear $TODO for the child.
+ my $orig_TODO = $self->find_TODO(undef, 1, undef);
- my $child = bless {
- %$self,
- '?' => $?,
- parent => $self,
- };
+ my $subevents = [];
+
+ my $hub = $ctx->stack->new_hub(
+ class => 'Test2::Hub::Subtest',
+ );
+
+ $hub->pre_filter(sub {
+ my ($active_hub, $e) = @_;
+
+ # Turn a diag into a todo diag
+ return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag';
+
+ return $e;
+ }, inherit => 1) if $orig_TODO;
+
+ $hub->listen(sub { push @$subevents => $_[1] });
- $? = 0;
- $child->{Name} = $name;
- $self->{child} = $child;
- Scalar::Util::weaken($self->{child});
+ $hub->set_nested( $parent->nested + 1 );
- return $child;
+ my $meta = $hub->meta(__PACKAGE__, {});
+ $meta->{Name} = $name;
+ $meta->{TODO} = $orig_TODO;
+ $meta->{TODO_PKG} = $ctx->trace->package;
+ $meta->{parent} = $parent;
+ $meta->{Test_Results} = [];
+ $meta->{subevents} = $subevents;
+ $meta->{subtest_id} = $hub->id;
+ $meta->{subtest_uuid} = $hub->uuid;
+ $meta->{subtest_buffered} = $parent->format ? 0 : 1;
+
+ $self->_add_ts_hooks;
+
+ $ctx->release;
+ return bless { Original_Pid => $$, Stack => $self->{Stack}, Hub => $hub, no_log_results => $self->{no_log_results} }, blessed($self);
}
sub finalize {
my $self = shift;
+ my $ok = 1;
+ ($ok) = @_ if @_;
- return unless $self->{parent};
-
- my $ctx = $self->ctx;
+ my $st_ctx = $self->ctx;
+ my $chub = $self->{Hub} || return $st_ctx->release;
- if ($self->{child}) {
- my $cname = $self->{child}->{Name};
- $ctx->throw("Can't call finalize() with child ($cname) active");
+ my $meta = $chub->meta(__PACKAGE__, {});
+ if ($meta->{child}) {
+ $self->croak("Can't call finalize() with child ($meta->{child}) active");
}
- $self->_ending($ctx);
- my $passing = $ctx->stream->is_passing;
- my $count = $ctx->stream->count;
- my $name = $self->{Name};
- $ctx = undef;
+ local $? = 0; # don't fail if $subtests happened to set $? nonzero
- my $stream = $self->{stream} || Test::Stream->shared;
+ $self->{Stack}->pop($chub);
+
+ $self->find_TODO($meta->{TODO_PKG}, 1, $meta->{TODO});
my $parent = $self->parent;
- $self->{parent}->{child} = undef;
- $self->{parent} = undef;
+ my $ctx = $parent->ctx;
+ my $trace = $ctx->trace;
+ delete $ctx->hub->meta(__PACKAGE__, {})->{child};
+
+ $chub->finalize($trace->snapshot(hid => $chub->hid, nested => $chub->nested), 1)
+ if $ok
+ && $chub->count
+ && !$chub->no_ending
+ && !$chub->ended;
+
+ my $plan = $chub->plan || 0;
+ my $count = $chub->count;
+ my $failed = $chub->failed;
+ my $passed = $chub->is_passing;
+
+ my $num_extra = $plan =~ m/\D/ ? 0 : $count - $plan;
+ if ($count && $num_extra != 0) {
+ my $s = $plan == 1 ? '' : 's';
+ $st_ctx->diag(<<"FAIL");
+Looks like you planned $plan test$s but ran $count.
+FAIL
+ }
+
+ if ($failed) {
+ my $s = $failed == 1 ? '' : 's';
+
+ my $qualifier = $num_extra == 0 ? '' : ' run';
- $? = $self->{'?'};
+ $st_ctx->diag(<<"FAIL");
+Looks like you failed $failed test$s of $count$qualifier.
+FAIL
+ }
+
+ if (!$passed && !$failed && $count && !$num_extra) {
+ $st_ctx->diag(<<"FAIL");
+All assertions inside the subtest passed, but errors were encountered.
+FAIL
+ }
+
+ $st_ctx->release;
+
+ unless ($chub->bailed_out) {
+ my $plan = $chub->plan;
+ if ( $plan && $plan eq 'SKIP' ) {
+ $parent->skip($chub->skip_reason, $meta->{Name});
+ }
+ elsif ( !$chub->count ) {
+ $parent->ok( 0, sprintf q[No tests run for subtest "%s"], $meta->{Name} );
+ }
+ else {
+ $parent->{subevents} = $meta->{subevents};
+ $parent->{subtest_id} = $meta->{subtest_id};
+ $parent->{subtest_uuid} = $meta->{subtest_uuid};
+ $parent->{subtest_buffered} = $meta->{subtest_buffered};
+ $parent->ok( $chub->is_passing, $meta->{Name} );
+ }
+ }
- $ctx = $parent->ctx;
- $ctx->child('pop', $self->{Name});
+ $ctx->release;
+ return $chub->is_passing;
}
-sub in_subtest {
+sub subtest {
my $self = shift;
+ my ($name, $code, @args) = @_;
my $ctx = $self->ctx;
- return scalar @{$ctx->stream->subtests};
-}
+ $ctx->throw("subtest()'s second argument must be a code ref")
+ unless $code && reftype($code) eq 'CODE';
-sub parent { $_[0]->{parent} }
-sub name { $_[0]->{Name} }
+ $name ||= "Child of " . $self->name;
-sub DESTROY {
- my $self = shift;
- return unless $self->{parent};
- return if $self->{Skip_All};
- $self->{parent}->is_passing(0);
- my $name = $self->{Name};
- die "Child ($name) exited without calling finalize()";
-}
-#############################
-# }}} Children and subtests #
-#############################
+ $_->($name,$code,@args)
+ for Test2::API::test2_list_pre_subtest_callbacks();
-#####################################
-# {{{ stuff for TODO status #
-#####################################
+ $ctx->note("Subtest: $name");
-sub find_TODO {
- my ($self, $pack, $set, $new_value) = @_;
-
- unless ($pack) {
- if (my $ctx = Test::Stream::Context->peek) {
- $pack = $ctx->package;
- my $old = $ctx->todo;
- $ctx->set_todo($new_value) if $set;
- return $old;
+ my $child = $self->child($name);
+
+ my $start_pid = $$;
+ my $st_ctx;
+ my ($ok, $err, $finished, $child_error);
+ T2_SUBTEST_WRAPPER: {
+ my $ctx = $self->ctx;
+ $st_ctx = $ctx->snapshot;
+ $ctx->release;
+ $ok = eval { local $Level = 1; $code->(@args); 1 };
+ ($err, $child_error) = ($@, $?);
+
+ # They might have done 'BEGIN { skip_all => "whatever" }'
+ if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && blessed($err) eq 'Test::Builder::Exception')) {
+ $ok = undef;
+ $err = undef;
}
+ else {
+ $finished = 1;
+ }
+ }
- $pack = $self->exported_to || return;
+ if ($start_pid != $$ && !$INC{'Test2/IPC.pm'}) {
+ warn $ok ? "Forked inside subtest, but subtest never finished!\n" : $err;
+ exit 255;
}
- no strict 'refs'; ## no critic
- no warnings 'once';
- my $old_value = ${$pack . '::TODO'};
- $set and ${$pack . '::TODO'} = $new_value;
- return $old_value;
+ my $trace = $ctx->trace;
+
+ if (!$finished) {
+ if(my $bailed = $st_ctx->hub->bailed_out) {
+ my $chub = $child->{Hub};
+ $self->{Stack}->pop($chub);
+ $ctx->bail($bailed->reason);
+ }
+ my $code = $st_ctx->hub->exit_code;
+ $ok = !$code;
+ $err = "Subtest ended with exit code $code" if $code;
+ }
+
+ my $st_hub = $st_ctx->hub;
+ my $plan = $st_hub->plan;
+ my $count = $st_hub->count;
+
+ if (!$count && (!defined($plan) || "$plan" ne 'SKIP')) {
+ $st_ctx->plan(0) unless defined $plan;
+ $st_ctx->diag('No tests run!');
+ }
+
+ $child->finalize($st_ctx->trace);
+
+ $ctx->release;
+
+ die $err unless $ok;
+
+ $? = $child_error if defined $child_error;
+
+ return $st_hub->is_passing;
}
-sub todo {
- my ($self, $pack) = @_;
+sub name {
+ my $self = shift;
+ my $ctx = $self->ctx;
+ release $ctx, $ctx->hub->meta(__PACKAGE__, {})->{Name};
+}
+
+sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
+ my ($self, %params) = @_;
+
+ Test2::API::test2_unset_is_end();
+
+ # We leave this a global because it has to be localized and localizing
+ # hash keys is just asking for pain. Also, it was documented.
+ $Level = 1;
- return $self->{Todo} if defined $self->{Todo};
+ $self->{no_log_results} = $ENV{TEST_NO_LOG_RESULTS} ? 1 : 0
+ unless $params{singleton};
+
+ $self->{Original_Pid} = Test2::API::test2_in_preload() ? -1 : $$;
my $ctx = $self->ctx;
+ my $hub = $ctx->hub;
+ $ctx->release;
+ unless ($params{singleton}) {
+ $hub->reset_state();
+ $hub->_tb_reset();
+ }
+
+ $ctx = $self->ctx;
+
+ my $meta = $ctx->hub->meta(__PACKAGE__, {});
+ %$meta = (
+ Name => $0,
+ Ending => 0,
+ Done_Testing => undef,
+ Skip_All => 0,
+ Test_Results => [],
+ parent => $meta->{parent},
+ );
+
+ $self->{Exported_To} = undef unless $params{singleton};
+
+ $self->{Orig_Handles} ||= do {
+ my $format = $ctx->hub->format;
+ my $out;
+ if ($format && $format->isa('Test2::Formatter::TAP')) {
+ $out = $format->handles;
+ }
+ $out ? [@$out] : [];
+ };
+
+ $self->use_numbers(1);
+ $self->no_header(0) unless $params{singleton};
+ $self->no_ending(0) unless $params{singleton};
+ $self->reset_outputs;
- my $todo = $self->find_TODO($pack);
- return $todo if defined $todo;
+ $ctx->release;
- return '';
+ return;
}
-sub in_todo {
- my $self = shift;
+
+my %plan_cmds = (
+ no_plan => \&no_plan,
+ skip_all => \&skip_all,
+ tests => \&_plan_tests,
+);
+
+sub plan {
+ my( $self, $cmd, $arg ) = @_;
+
+ return unless $cmd;
my $ctx = $self->ctx;
- return 1 if $ctx->in_todo;
+ my $hub = $ctx->hub;
+
+ $ctx->throw("You tried to plan twice") if $hub->plan;
+
+ local $Level = $Level + 1;
+
+ if( my $method = $plan_cmds{$cmd} ) {
+ local $Level = $Level + 1;
+ $self->$method($arg);
+ }
+ else {
+ my @args = grep { defined } ( $cmd, $arg );
+ $ctx->throw("plan() doesn't understand @args");
+ }
- return (defined $self->{Todo} || $self->find_TODO) ? 1 : 0;
+ release $ctx, 1;
}
-sub todo_start {
- my $self = shift;
- my $message = @_ ? shift : '';
- $self->{Start_Todo}++;
- if ($self->in_todo) {
- push @{$self->{Todo_Stack}} => $self->todo;
+sub _plan_tests {
+ my($self, $arg) = @_;
+
+ my $ctx = $self->ctx;
+
+ if($arg) {
+ local $Level = $Level + 1;
+ $self->expected_tests($arg);
+ }
+ elsif( !defined $arg ) {
+ $ctx->throw("Got an undefined number of tests");
+ }
+ else {
+ $ctx->throw("You said to run 0 tests");
}
- $self->{Todo} = $message;
- return;
+ $ctx->release;
}
-sub todo_end {
+
+sub expected_tests {
my $self = shift;
+ my($max) = @_;
- if (!$self->{Start_Todo}) {
- $self->ctx(-1)->throw('todo_end() called without todo_start()');
- }
+ my $ctx = $self->ctx;
- $self->{Start_Todo}--;
+ if(@_) {
+ $self->croak("Number of tests must be a positive integer. You gave it '$max'")
+ unless $max =~ /^\+?\d+$/;
- if ($self->{Start_Todo} && @{$self->{Todo_Stack}}) {
- $self->{Todo} = pop @{$self->{Todo_Stack}};
+ $ctx->plan($max);
}
- else {
- delete $self->{Todo};
+
+ my $hub = $ctx->hub;
+
+ $ctx->release;
+
+ my $plan = $hub->plan;
+ return 0 unless $plan;
+ return 0 if $plan =~ m/\D/;
+ return $plan;
+}
+
+
+sub no_plan {
+ my($self, $arg) = @_;
+
+ my $ctx = $self->ctx;
+
+ if (defined $ctx->hub->plan) {
+ warn "Plan already set, no_plan() is a no-op, this will change to a hard failure in the future.";
+ $ctx->release;
+ return;
}
- return;
+ $ctx->alert("no_plan takes no arguments") if $arg;
+
+ $ctx->hub->plan('NO PLAN');
+
+ release $ctx, 1;
}
-#####################################
-# }}} Finding Testers and Providers #
-#####################################
-################
-# {{{ Planning #
-################
+sub done_testing {
+ my($self, $num_tests) = @_;
-my %PLAN_CMDS = (
- no_plan => 'no_plan',
- skip_all => 'skip_all',
- tests => '_plan_tests',
-);
+ my $ctx = $self->ctx;
-sub plan {
- my ($self, $cmd, @args) = @_;
+ my $meta = $ctx->hub->meta(__PACKAGE__, {});
- my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx();
- WARN_OF_OVERRIDE(plan => $ctx);
+ if ($meta->{Done_Testing}) {
+ my ($file, $line) = @{$meta->{Done_Testing}}[1,2];
+ local $ctx->hub->{ended}; # OMG This is awful.
+ $self->ok(0, "done_testing() was already called at $file line $line");
+ $ctx->release;
+ return;
+ }
+ $meta->{Done_Testing} = [$ctx->trace->call];
- return unless $cmd;
+ my $plan = $ctx->hub->plan;
+ my $count = $ctx->hub->count;
- if (my $method = $PLAN_CMDS{$cmd}) {
- $self->$method(@args);
+ # If done_testing() specified the number of tests, shut off no_plan
+ if( defined $num_tests ) {
+ $ctx->plan($num_tests) if !$plan || $plan eq 'NO PLAN';
+ }
+ elsif ($count && defined $num_tests && $count != $num_tests) {
+ $self->ok(0, "planned to run @{[ $self->expected_tests ]} but done_testing() expects $num_tests");
}
else {
- my @in = grep { defined } ($cmd, @args);
- $self->ctx->throw("plan() doesn't understand @in");
+ $num_tests = $self->current_test;
}
- return 1;
+ if( $self->expected_tests && $num_tests != $self->expected_tests ) {
+ $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
+ "but done_testing() expects $num_tests");
+ }
+
+ $ctx->plan($num_tests) if $ctx->hub->plan && $ctx->hub->plan eq 'NO PLAN';
+
+ $ctx->hub->finalize($ctx->trace, 1);
+
+ release $ctx, 1;
}
-sub skip_all {
- my ($self, $reason) = @_;
- $self->{Skip_All} = 1;
+sub has_plan {
+ my $self = shift;
- my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx();
+ my $ctx = $self->ctx;
+ my $plan = $ctx->hub->plan;
+ $ctx->release;
- $ctx->_plan(0, 'SKIP', $reason);
+ return( $plan ) if $plan && $plan !~ m/\D/;
+ return('no_plan') if $plan && $plan eq 'NO PLAN';
+ return(undef);
}
-sub no_plan {
- my ($self, @args) = @_;
- my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx();
+sub skip_all {
+ my( $self, $reason ) = @_;
- $ctx->alert("no_plan takes no arguments") if @args;
- $ctx->_plan(0, 'NO PLAN');
+ my $ctx = $self->ctx;
- return 1;
+ $ctx->hub->meta(__PACKAGE__, {})->{Skip_All} = $reason || 1;
+
+ # Work around old perl bug
+ if ($] < 5.020000) {
+ my $begin = 0;
+ my $level = 0;
+ while (my @call = caller($level++)) {
+ last unless @call && $call[0];
+ next unless $call[3] =~ m/::BEGIN$/;
+ $begin++;
+ last;
+ }
+ # HACK!
+ die 'Label not found for "last T2_SUBTEST_WRAPPER"' if $begin && $ctx->hub->meta(__PACKAGE__, {})->{parent};
+ }
+
+ $ctx->plan(0, SKIP => $reason);
}
-sub _plan_tests {
- my ($self, $arg) = @_;
- my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx();
+sub exported_to {
+ my( $self, $pack ) = @_;
+
+ if( defined $pack ) {
+ $self->{Exported_To} = $pack;
+ }
+ return $self->{Exported_To};
+}
+
+
+sub ok {
+ my( $self, $test, $name ) = @_;
- if ($arg) {
- $ctx->throw("Number of tests must be a positive integer. You gave it '$arg'")
- unless $arg =~ /^\+?\d+$/;
+ my $ctx = $self->ctx;
+
+ # $test might contain an object which we don't want to accidentally
+ # store, so we turn it into a boolean.
+ $test = $test ? 1 : 0;
+
+ # In case $name is a string overloaded object, force it to stringify.
+ no warnings qw/uninitialized numeric/;
+ $name = "$name" if defined $name;
+
+ # Profiling showed that the regex here was a huge time waster, doing the
+ # numeric addition first cuts our profile time from ~300ms to ~50ms
+ $self->diag(<<" ERR") if 0 + $name && $name =~ /^[\d\s]+$/;
+ You named your test '$name'. You shouldn't use numbers for your test names.
+ Very confusing.
+ ERR
+ use warnings qw/uninitialized numeric/;
+
+ my $trace = $ctx->{trace};
+ my $hub = $ctx->{hub};
+
+ my $result = {
+ ok => $test,
+ actual_ok => $test,
+ reason => '',
+ type => '',
+ (name => defined($name) ? $name : ''),
+ };
+
+ $hub->{_meta}->{+__PACKAGE__}->{Test_Results}[ $hub->{count} ] = $result unless $self->{no_log_results};
- $ctx->_plan($arg);
+ my $orig_name = $name;
+
+ my @attrs;
+ my $subevents = delete $self->{subevents};
+ my $subtest_id = delete $self->{subtest_id};
+ my $subtest_uuid = delete $self->{subtest_uuid};
+ my $subtest_buffered = delete $self->{subtest_buffered};
+ my $epkg = 'Test2::Event::Ok';
+ if ($subevents) {
+ $epkg = 'Test2::Event::Subtest';
+ push @attrs => (subevents => $subevents, subtest_id => $subtest_id, subtest_uuid => $subtest_uuid, buffered => $subtest_buffered);
}
- elsif (!defined $arg) {
- $ctx->throw("Got an undefined number of tests");
+
+ my $e = bless {
+ trace => bless( {%$trace}, 'Test2::EventFacet::Trace'),
+ pass => $test,
+ name => $name,
+ _meta => {'Test::Builder' => $result},
+ effective_pass => $test,
+ @attrs,
+ }, $epkg;
+ $hub->send($e);
+
+ $self->_ok_debug($trace, $orig_name) unless($test);
+
+ $ctx->release;
+ return $test;
+}
+
+sub _ok_debug {
+ my $self = shift;
+ my ($trace, $orig_name) = @_;
+
+ my $is_todo = $self->in_todo;
+
+ my $msg = $is_todo ? "Failed (TODO)" : "Failed";
+
+ my (undef, $file, $line) = $trace->call;
+ if (defined $orig_name) {
+ $self->diag(qq[ $msg test '$orig_name'\n at $file line $line.\n]);
}
else {
- $ctx->throw("You said to run 0 tests");
+ $self->diag(qq[ $msg test at $file line $line.\n]);
}
-
- return;
}
-sub done_testing {
- my ($self, $num_tests) = @_;
+sub _diag_fh {
+ my $self = shift;
+ local $Level = $Level + 1;
+ return $self->in_todo ? $self->todo_output : $self->failure_output;
+}
- my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx();
- WARN_OF_OVERRIDE(done_testing => $ctx);
+sub _unoverload {
+ my ($self, $type, $thing) = @_;
- my $out = $ctx->stream->done_testing($ctx, $num_tests);
- return $out;
+ return unless ref $$thing;
+ return unless blessed($$thing) || scalar $self->_try(sub{ $$thing->isa('UNIVERSAL') });
+ {
+ local ($!, $@);
+ require overload;
+ }
+ my $string_meth = overload::Method( $$thing, $type ) || return;
+ $$thing = $$thing->$string_meth();
}
-################
-# }}} Planning #
-################
+sub _unoverload_str {
+ my $self = shift;
-#############################
-# {{{ Base Event Producers #
-#############################
+ $self->_unoverload( q[""], $_ ) for @_;
+}
-sub ok {
+sub _unoverload_num {
my $self = shift;
- my($test, $name) = @_;
- my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx();
- WARN_OF_OVERRIDE(ok => $ctx);
+ $self->_unoverload( '0+', $_ ) for @_;
- if ($self->{child}) {
- $self->is_passing(0);
- $ctx->throw("Cannot run test ($name) with active children");
+ for my $val (@_) {
+ next unless $self->_is_dualvar($$val);
+ $$val = $$val + 0;
}
-
- $ctx->_unwind_ok($test, $name);
- return $test ? 1 : 0;
}
-sub BAIL_OUT {
- my( $self, $reason ) = @_;
- $self->ctx()->bail($reason);
+# This is a hack to detect a dualvar such as $!
+sub _is_dualvar {
+ my( $self, $val ) = @_;
+
+ # Objects are not dualvars.
+ return 0 if ref $val;
+
+ no warnings 'numeric';
+ my $numval = $val + 0;
+ return ($numval != 0 and $numval ne $val ? 1 : 0);
}
-sub skip {
- my( $self, $why ) = @_;
- $why ||= '';
- unoverload_str( \$why );
- my $ctx = $self->ctx();
- $ctx->set_skip($why);
- $ctx->ok(1, '');
- $ctx->set_skip(undef);
+sub is_eq {
+ my( $self, $got, $expect, $name ) = @_;
+
+ my $ctx = $self->ctx;
+
+ local $Level = $Level + 1;
+
+ if( !defined $got || !defined $expect ) {
+ # undef only matches undef and nothing else
+ my $test = !defined $got && !defined $expect;
+
+ $self->ok( $test, $name );
+ $self->_is_diag( $got, 'eq', $expect ) unless $test;
+ $ctx->release;
+ return $test;
+ }
+
+ release $ctx, $self->cmp_ok( $got, 'eq', $expect, $name );
}
-sub todo_skip {
- my( $self, $why ) = @_;
- $why ||= '';
- unoverload_str( \$why );
- my $ctx = $self->ctx();
- $ctx->set_skip($why);
- $ctx->set_todo($why);
- $ctx->ok(0, '');
- $ctx->set_skip(undef);
- $ctx->set_todo(undef);
+sub is_num {
+ my( $self, $got, $expect, $name ) = @_;
+ my $ctx = $self->ctx;
+ local $Level = $Level + 1;
+
+ if( !defined $got || !defined $expect ) {
+ # undef only matches undef and nothing else
+ my $test = !defined $got && !defined $expect;
+
+ $self->ok( $test, $name );
+ $self->_is_diag( $got, '==', $expect ) unless $test;
+ $ctx->release;
+ return $test;
+ }
+
+ release $ctx, $self->cmp_ok( $got, '==', $expect, $name );
}
-sub diag {
- my $self = shift;
- my $msg = join '', map { defined($_) ? $_ : 'undef' } @_;
- my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx();
- WARN_OF_OVERRIDE(diag => $ctx);
+sub _diag_fmt {
+ my( $self, $type, $val ) = @_;
+
+ if( defined $$val ) {
+ if( $type eq 'eq' or $type eq 'ne' ) {
+ # quote and force string context
+ $$val = "'$$val'";
+ }
+ else {
+ # force numeric context
+ $self->_unoverload_num($val);
+ }
+ }
+ else {
+ $$val = 'undef';
+ }
+
+ return;
+}
+
+
+sub _is_diag {
+ my( $self, $got, $type, $expect ) = @_;
+
+ $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
+
+ local $Level = $Level + 1;
+ return $self->diag(<<"DIAGNOSTIC");
+ got: $got
+ expected: $expect
+DIAGNOSTIC
+
+}
+
+sub _isnt_diag {
+ my( $self, $got, $type ) = @_;
+
+ $self->_diag_fmt( $type, \$got );
+
+ local $Level = $Level + 1;
+ return $self->diag(<<"DIAGNOSTIC");
+ got: $got
+ expected: anything else
+DIAGNOSTIC
+}
+
+
+sub isnt_eq {
+ my( $self, $got, $dont_expect, $name ) = @_;
+ my $ctx = $self->ctx;
+ local $Level = $Level + 1;
+
+ if( !defined $got || !defined $dont_expect ) {
+ # undef only matches undef and nothing else
+ my $test = defined $got || defined $dont_expect;
+
+ $self->ok( $test, $name );
+ $self->_isnt_diag( $got, 'ne' ) unless $test;
+ $ctx->release;
+ return $test;
+ }
+
+ release $ctx, $self->cmp_ok( $got, 'ne', $dont_expect, $name );
+}
+
+sub isnt_num {
+ my( $self, $got, $dont_expect, $name ) = @_;
+ my $ctx = $self->ctx;
+ local $Level = $Level + 1;
+
+ if( !defined $got || !defined $dont_expect ) {
+ # undef only matches undef and nothing else
+ my $test = defined $got || defined $dont_expect;
+
+ $self->ok( $test, $name );
+ $self->_isnt_diag( $got, '!=' ) unless $test;
+ $ctx->release;
+ return $test;
+ }
+
+ release $ctx, $self->cmp_ok( $got, '!=', $dont_expect, $name );
+}
+
+
+sub like {
+ my( $self, $thing, $regex, $name ) = @_;
+ my $ctx = $self->ctx;
+
+ local $Level = $Level + 1;
+
+ release $ctx, $self->_regex_ok( $thing, $regex, '=~', $name );
+}
+
+sub unlike {
+ my( $self, $thing, $regex, $name ) = @_;
+ my $ctx = $self->ctx;
+
+ local $Level = $Level + 1;
+
+ release $ctx, $self->_regex_ok( $thing, $regex, '!~', $name );
+}
+
+
+my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
+
+# Bad, these are not comparison operators. Should we include more?
+my %cmp_ok_bl = map { ( $_, 1 ) } ( "=", "+=", ".=", "x=", "^=", "|=", "||=", "&&=", "...");
+
+sub cmp_ok {
+ my( $self, $got, $type, $expect, $name ) = @_;
+ my $ctx = $self->ctx;
+
+ if ($cmp_ok_bl{$type}) {
+ $ctx->throw("$type is not a valid comparison operator in cmp_ok()");
+ }
+
+ my ($test, $succ);
+ my $error;
+ {
+ ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+ local( $@, $!, $SIG{__DIE__} ); # isolate eval
+
+ my($pack, $file, $line) = $ctx->trace->call();
+
+ # This is so that warnings come out at the caller's level
+ $succ = eval qq[
+#line $line "(eval in cmp_ok) $file"
+\$test = (\$got $type \$expect);
+1;
+];
+ $error = $@;
+ }
+ local $Level = $Level + 1;
+ my $ok = $self->ok( $test, $name );
+
+ # Treat overloaded objects as numbers if we're asked to do a
+ # numeric comparison.
+ my $unoverload
+ = $numeric_cmps{$type}
+ ? '_unoverload_num'
+ : '_unoverload_str';
+
+ $self->diag(<<"END") unless $succ;
+An error occurred while using $type:
+------------------------------------
+$error
+------------------------------------
+END
+
+ unless($ok) {
+ $self->$unoverload( \$got, \$expect );
+
+ if( $type =~ /^(eq|==)$/ ) {
+ $self->_is_diag( $got, $type, $expect );
+ }
+ elsif( $type =~ /^(ne|!=)$/ ) {
+ no warnings;
+ my $eq = ($got eq $expect || $got == $expect)
+ && (
+ (defined($got) xor defined($expect))
+ || (length($got) != length($expect))
+ );
+ use warnings;
+
+ if ($eq) {
+ $self->_cmp_diag( $got, $type, $expect );
+ }
+ else {
+ $self->_isnt_diag( $got, $type );
+ }
+ }
+ else {
+ $self->_cmp_diag( $got, $type, $expect );
+ }
+ }
+ return release $ctx, $ok;
+}
+
+sub _cmp_diag {
+ my( $self, $got, $type, $expect ) = @_;
+
+ $got = defined $got ? "'$got'" : 'undef';
+ $expect = defined $expect ? "'$expect'" : 'undef';
+
+ local $Level = $Level + 1;
+ return $self->diag(<<"DIAGNOSTIC");
+ $got
+ $type
+ $expect
+DIAGNOSTIC
+}
+
+sub _caller_context {
+ my $self = shift;
+
+ my( $pack, $file, $line ) = $self->caller(1);
+
+ my $code = '';
+ $code .= "#line $line $file\n" if defined $file and defined $line;
+
+ return $code;
+}
+
+
+sub BAIL_OUT {
+ my( $self, $reason ) = @_;
+
+ my $ctx = $self->ctx;
+
+ $self->{Bailed_Out} = 1;
+
+ $ctx->bail($reason);
+}
+
+
+{
+ no warnings 'once';
+ *BAILOUT = \&BAIL_OUT;
+}
+
+sub skip {
+ my( $self, $why, $name ) = @_;
+ $why ||= '';
+ $name = '' unless defined $name;
+ $self->_unoverload_str( \$why );
+
+ my $ctx = $self->ctx;
+
+ $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = {
+ 'ok' => 1,
+ actual_ok => 1,
+ name => $name,
+ type => 'skip',
+ reason => $why,
+ } unless $self->{no_log_results};
+
+ $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
+ $name =~ s{\n}{\n# }sg;
+ $why =~ s{\n}{\n# }sg;
+
+ my $tctx = $ctx->snapshot;
+ $tctx->skip('', $why);
+
+ return release $ctx, 1;
+}
+
+
+sub todo_skip {
+ my( $self, $why ) = @_;
+ $why ||= '';
+
+ my $ctx = $self->ctx;
+
+ $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = {
+ 'ok' => 1,
+ actual_ok => 0,
+ name => '',
+ type => 'todo_skip',
+ reason => $why,
+ } unless $self->{no_log_results};
+
+ $why =~ s{\n}{\n# }sg;
+ my $tctx = $ctx->snapshot;
+ $tctx->send_event( 'Skip', todo => $why, todo_diag => 1, reason => $why, pass => 0);
+
+ return release $ctx, 1;
+}
+
+
+sub maybe_regex {
+ my( $self, $regex ) = @_;
+ my $usable_regex = undef;
+
+ return $usable_regex unless defined $regex;
+
+ my( $re, $opts );
+
+ # Check for qr/foo/
+ if( _is_qr($regex) ) {
+ $usable_regex = $regex;
+ }
+ # Check for '/foo/' or 'm,foo,'
+ elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
+ ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
+ )
+ {
+ $usable_regex = length $opts ? "(?$opts)$re" : $re;
+ }
+
+ return $usable_regex;
+}
+
+sub _is_qr {
+ my $regex = shift;
+
+ # is_regexp() checks for regexes in a robust manner, say if they're
+ # blessed.
+ return re::is_regexp($regex) if defined &re::is_regexp;
+ return ref $regex eq 'Regexp';
+}
+
+sub _regex_ok {
+ my( $self, $thing, $regex, $cmp, $name ) = @_;
+
+ my $ok = 0;
+ my $usable_regex = $self->maybe_regex($regex);
+ unless( defined $usable_regex ) {
+ local $Level = $Level + 1;
+ $ok = $self->ok( 0, $name );
+ $self->diag(" '$regex' doesn't look much like a regex to me.");
+ return $ok;
+ }
+
+ {
+ my $test;
+ my $context = $self->_caller_context;
+
+ {
+ ## no critic (BuiltinFunctions::ProhibitStringyEval)
+
+ local( $@, $!, $SIG{__DIE__} ); # isolate eval
+
+ # No point in issuing an uninit warning, they'll see it in the diagnostics
+ no warnings 'uninitialized';
+
+ $test = eval $context . q{$test = $thing =~ /$usable_regex/ ? 1 : 0};
+ }
+
+ $test = !$test if $cmp eq '!~';
+
+ local $Level = $Level + 1;
+ $ok = $self->ok( $test, $name );
+ }
+
+ unless($ok) {
+ $thing = defined $thing ? "'$thing'" : 'undef';
+ my $match = $cmp eq '=~' ? "doesn't match" : "matches";
+
+ local $Level = $Level + 1;
+ $self->diag( sprintf <<'DIAGNOSTIC', $thing, $match, $regex );
+ %s
+ %13s '%s'
+DIAGNOSTIC
+
+ }
+
+ return $ok;
+}
+
+
+sub is_fh {
+ my $self = shift;
+ my $maybe_fh = shift;
+ return 0 unless defined $maybe_fh;
+
+ return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
+ return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
+
+ return eval { $maybe_fh->isa("IO::Handle") } ||
+ eval { tied($maybe_fh)->can('TIEHANDLE') };
+}
+
+
+sub level {
+ my( $self, $level ) = @_;
+
+ if( defined $level ) {
+ $Level = $level;
+ }
+ return $Level;
+}
+
+
+sub use_numbers {
+ my( $self, $use_nums ) = @_;
+
+ my $ctx = $self->ctx;
+ my $format = $ctx->hub->format;
+ unless ($format && $format->can('no_numbers') && $format->can('set_no_numbers')) {
+ warn "The current formatter does not support 'use_numbers'" if $format;
+ return release $ctx, 0;
+ }
+
+ $format->set_no_numbers(!$use_nums) if defined $use_nums;
+
+ return release $ctx, $format->no_numbers ? 0 : 1;
+}
+
+BEGIN {
+ for my $method (qw(no_header no_diag)) {
+ my $set = "set_$method";
+ my $code = sub {
+ my( $self, $no ) = @_;
+
+ my $ctx = $self->ctx;
+ my $format = $ctx->hub->format;
+ unless ($format && $format->can($set)) {
+ warn "The current formatter does not support '$method'" if $format;
+ $ctx->release;
+ return
+ }
+
+ $format->$set($no) if defined $no;
+
+ return release $ctx, $format->$method ? 1 : 0;
+ };
+
+ no strict 'refs'; ## no critic
+ *$method = $code;
+ }
+}
+
+sub no_ending {
+ my( $self, $no ) = @_;
+
+ my $ctx = $self->ctx;
+
+ $ctx->hub->set_no_ending($no) if defined $no;
+
+ return release $ctx, $ctx->hub->no_ending;
+}
+
+sub diag {
+ my $self = shift;
+ return unless @_;
+
+ my $text = join '' => map {defined($_) ? $_ : 'undef'} @_;
+
+ if (Test2::API::test2_in_preload()) {
+ chomp($text);
+ $text =~ s/^/# /msg;
+ print STDERR $text, "\n";
+ return 0;
+ }
+
+ my $ctx = $self->ctx;
+ $ctx->diag($text);
+ $ctx->release;
+ return 0;
+}
+
+
+sub note {
+ my $self = shift;
+ return unless @_;
+
+ my $text = join '' => map {defined($_) ? $_ : 'undef'} @_;
+
+ if (Test2::API::test2_in_preload()) {
+ chomp($text);
+ $text =~ s/^/# /msg;
+ print STDOUT $text, "\n";
+ return 0;
+ }
+
+ my $ctx = $self->ctx;
+ $ctx->note($text);
+ $ctx->release;
+ return 0;
+}
+
+
+sub explain {
+ my $self = shift;
+
+ local ($@, $!);
+ require Data::Dumper;
+
+ return map {
+ ref $_
+ ? do {
+ my $dumper = Data::Dumper->new( [$_] );
+ $dumper->Indent(1)->Terse(1);
+ $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
+ $dumper->Dump;
+ }
+ : $_
+ } @_;
+}
+
+
+sub output {
+ my( $self, $fh ) = @_;
+
+ my $ctx = $self->ctx;
+ my $format = $ctx->hub->format;
+ $ctx->release;
+ return unless $format && $format->isa('Test2::Formatter::TAP');
+
+ $format->handles->[Test2::Formatter::TAP::OUT_STD()] = $self->_new_fh($fh)
+ if defined $fh;
+
+ return $format->handles->[Test2::Formatter::TAP::OUT_STD()];
+}
+
+sub failure_output {
+ my( $self, $fh ) = @_;
+
+ my $ctx = $self->ctx;
+ my $format = $ctx->hub->format;
+ $ctx->release;
+ return unless $format && $format->isa('Test2::Formatter::TAP');
+
+ $format->handles->[Test2::Formatter::TAP::OUT_ERR()] = $self->_new_fh($fh)
+ if defined $fh;
+
+ return $format->handles->[Test2::Formatter::TAP::OUT_ERR()];
+}
+
+sub todo_output {
+ my( $self, $fh ) = @_;
+
+ my $ctx = $self->ctx;
+ my $format = $ctx->hub->format;
+ $ctx->release;
+ return unless $format && $format->isa('Test::Builder::Formatter');
+
+ $format->handles->[Test::Builder::Formatter::OUT_TODO()] = $self->_new_fh($fh)
+ if defined $fh;
+
+ return $format->handles->[Test::Builder::Formatter::OUT_TODO()];
+}
+
+sub _new_fh {
+ my $self = shift;
+ my($file_or_fh) = shift;
+
+ my $fh;
+ if( $self->is_fh($file_or_fh) ) {
+ $fh = $file_or_fh;
+ }
+ elsif( ref $file_or_fh eq 'SCALAR' ) {
+ # Scalar refs as filehandles was added in 5.8.
+ if( $] >= 5.008 ) {
+ open $fh, ">>", $file_or_fh
+ or $self->croak("Can't open scalar ref $file_or_fh: $!");
+ }
+ # Emulate scalar ref filehandles with a tie.
+ else {
+ $fh = Test::Builder::IO::Scalar->new($file_or_fh)
+ or $self->croak("Can't tie scalar ref $file_or_fh");
+ }
+ }
+ else {
+ open $fh, ">", $file_or_fh
+ or $self->croak("Can't open test output log $file_or_fh: $!");
+ _autoflush($fh);
+ }
+
+ return $fh;
+}
+
+sub _autoflush {
+ my($fh) = shift;
+ my $old_fh = select $fh;
+ $| = 1;
+ select $old_fh;
+
+ return;
+}
+
+
+sub reset_outputs {
+ my $self = shift;
+
+ my $ctx = $self->ctx;
+ my $format = $ctx->hub->format;
+ $ctx->release;
+ return unless $format && $format->isa('Test2::Formatter::TAP');
+ $format->set_handles([@{$self->{Orig_Handles}}]) if $self->{Orig_Handles};
+
+ return;
+}
+
+
+sub carp {
+ my $self = shift;
+ my $ctx = $self->ctx;
+ $ctx->alert(join "", @_);
+ $ctx->release;
+}
+
+sub croak {
+ my $self = shift;
+ my $ctx = $self->ctx;
+ $ctx->throw(join "", @_);
+ $ctx->release;
+}
+
+
+sub current_test {
+ my( $self, $num ) = @_;
+
+ my $ctx = $self->ctx;
+ my $hub = $ctx->hub;
+
+ if( defined $num ) {
+ $hub->set_count($num);
+
+ unless ($self->{no_log_results}) {
+ # If the test counter is being pushed forward fill in the details.
+ my $test_results = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results};
+ if ($num > @$test_results) {
+ my $start = @$test_results ? @$test_results : 0;
+ for ($start .. $num - 1) {
+ $test_results->[$_] = {
+ 'ok' => 1,
+ actual_ok => undef,
+ reason => 'incrementing test number',
+ type => 'unknown',
+ name => undef
+ };
+ }
+ }
+ # If backward, wipe history. Its their funeral.
+ elsif ($num < @$test_results) {
+ $#{$test_results} = $num - 1;
+ }
+ }
+ }
+ return release $ctx, $hub->count;
+}
+
+
+sub is_passing {
+ my $self = shift;
+
+ my $ctx = $self->ctx;
+ my $hub = $ctx->hub;
+
+ if( @_ ) {
+ my ($bool) = @_;
+ $hub->set_failed(0) if $bool;
+ $hub->is_passing($bool);
+ }
+
+ return release $ctx, $hub->is_passing;
+}
+
+
+sub summary {
+ my($self) = shift;
+
+ return if $self->{no_log_results};
+
+ my $ctx = $self->ctx;
+ my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results};
+ $ctx->release;
+ return map { $_ ? $_->{'ok'} : () } @$data;
+}
+
+
+sub details {
+ my $self = shift;
+
+ return if $self->{no_log_results};
+
+ my $ctx = $self->ctx;
+ my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results};
+ $ctx->release;
+ return @$data;
+}
+
+
+sub find_TODO {
+ my( $self, $pack, $set, $new_value ) = @_;
+
+ my $ctx = $self->ctx;
+
+ $pack ||= $ctx->trace->package || $self->exported_to;
+ $ctx->release;
+
+ return unless $pack;
+
+ no strict 'refs'; ## no critic
+ no warnings 'once';
+ my $old_value = ${ $pack . '::TODO' };
+ $set and ${ $pack . '::TODO' } = $new_value;
+ return $old_value;
+}
+
+sub todo {
+ my( $self, $pack ) = @_;
+
+ local $Level = $Level + 1;
+ my $ctx = $self->ctx;
+ $ctx->release;
+
+ my $meta = $ctx->hub->meta(__PACKAGE__, {todo => []})->{todo};
+ return $meta->[-1]->[1] if $meta && @$meta;
+
+ $pack ||= $ctx->trace->package;
+
+ return unless $pack;
+
+ no strict 'refs'; ## no critic
+ no warnings 'once';
+ return ${ $pack . '::TODO' };
+}
+
+sub in_todo {
+ my $self = shift;
+
+ local $Level = $Level + 1;
+ my $ctx = $self->ctx;
+ $ctx->release;
+
+ my $meta = $ctx->hub->meta(__PACKAGE__, {todo => []})->{todo};
+ return 1 if $meta && @$meta;
+
+ my $pack = $ctx->trace->package || return 0;
+
+ no strict 'refs'; ## no critic
+ no warnings 'once';
+ my $todo = ${ $pack . '::TODO' };
+
+ return 0 unless defined $todo;
+ return 0 if "$todo" eq '';
+ return 1;
+}
+
+sub todo_start {
+ my $self = shift;
+ my $message = @_ ? shift : '';
+
+ my $ctx = $self->ctx;
+
+ my $hub = $ctx->hub;
+ my $filter = $hub->pre_filter(sub {
+ my ($active_hub, $e) = @_;
+
+ # Turn a diag into a todo diag
+ return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag';
+
+ # Set todo on ok's
+ if ($hub == $active_hub && $e->isa('Test2::Event::Ok')) {
+ $e->set_todo($message);
+ $e->set_effective_pass(1);
+
+ if (my $result = $e->get_meta(__PACKAGE__)) {
+ $result->{reason} ||= $message;
+ $result->{type} ||= 'todo';
+ $result->{ok} = 1;
+ }
+ }
+
+ return $e;
+ }, inherit => 1);
+
+ push @{$ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}} => [$filter, $message];
+
+ $ctx->release;
+
+ return;
+}
+
+sub todo_end {
+ my $self = shift;
+
+ my $ctx = $self->ctx;
+
+ my $set = pop @{$ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}};
+
+ $ctx->throw('todo_end() called without todo_start()') unless $set;
+
+ $ctx->hub->pre_unfilter($set->[0]);
+
+ $ctx->release;
+
+ return;
+}
+
+
+sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
+ my( $self ) = @_;
+
+ my $ctx = $self->ctx;
+
+ my $trace = $ctx->trace;
+ $ctx->release;
+ return wantarray ? $trace->call : $trace->package;
+}
+
+
+sub _try {
+ my( $self, $code, %opts ) = @_;
+
+ my $error;
+ my $return;
+ {
+ local $!; # eval can mess up $!
+ local $@; # don't set $@ in the test
+ local $SIG{__DIE__}; # don't trip an outside DIE handler.
+ $return = eval { $code->() };
+ $error = $@;
+ }
+
+ die $error if $error and $opts{die_on_fail};
+
+ return wantarray ? ( $return, $error ) : $return;
+}
+
+sub _ending {
+ my $self = shift;
+ my ($ctx, $real_exit_code, $new) = @_;
+
+ unless ($ctx) {
+ my $octx = $self->ctx;
+ $ctx = $octx->snapshot;
+ $octx->release;
+ }
+
+ return if $ctx->hub->no_ending;
+ return if $ctx->hub->meta(__PACKAGE__, {})->{Ending}++;
+
+ # Don't bother with an ending if this is a forked copy. Only the parent
+ # should do the ending.
+ return unless $self->{Original_Pid} == $$;
+
+ my $hub = $ctx->hub;
+ return if $hub->bailed_out;
+
+ my $plan = $hub->plan;
+ my $count = $hub->count;
+ my $failed = $hub->failed;
+ my $passed = $hub->is_passing;
+ return unless $plan || $count || $failed;
+
+ # Ran tests but never declared a plan or hit done_testing
+ if( !$hub->plan and $hub->count ) {
+ $self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
+
+ if($real_exit_code) {
+ $self->diag(<<"FAIL");
+Looks like your test exited with $real_exit_code just after $count.
+FAIL
+ $$new ||= $real_exit_code;
+ return;
+ }
+
+ # But if the tests ran, handle exit code.
+ if($failed > 0) {
+ my $exit_code = $failed <= 254 ? $failed : 254;
+ $$new ||= $exit_code;
+ return;
+ }
+
+ $$new ||= 254;
+ return;
+ }
+
+ if ($real_exit_code && !$count) {
+ $self->diag("Looks like your test exited with $real_exit_code before it could output anything.");
+ $$new ||= $real_exit_code;
+ return;
+ }
+
+ return if $plan && "$plan" eq 'SKIP';
+
+ if (!$count) {
+ $self->diag('No tests run!');
+ $$new ||= 255;
+ return;
+ }
+
+ if ($real_exit_code) {
+ $self->diag(<<"FAIL");
+Looks like your test exited with $real_exit_code just after $count.
+FAIL
+ $$new ||= $real_exit_code;
+ return;
+ }
+
+ if ($plan eq 'NO PLAN') {
+ $ctx->plan( $count );
+ $plan = $hub->plan;
+ }
+
+ # Figure out if we passed or failed and print helpful messages.
+ my $num_extra = $count - $plan;
+
+ if ($num_extra != 0) {
+ my $s = $plan == 1 ? '' : 's';
+ $self->diag(<<"FAIL");
+Looks like you planned $plan test$s but ran $count.
+FAIL
+ }
+
+ if ($failed) {
+ my $s = $failed == 1 ? '' : 's';
+
+ my $qualifier = $num_extra == 0 ? '' : ' run';
+
+ $self->diag(<<"FAIL");
+Looks like you failed $failed test$s of $count$qualifier.
+FAIL
+ }
+
+ if (!$passed && !$failed && $count && !$num_extra) {
+ $ctx->diag(<<"FAIL");
+All assertions passed, but errors were encountered.
+FAIL
+ }
+
+ my $exit_code = 0;
+ if ($failed) {
+ $exit_code = $failed <= 254 ? $failed : 254;
+ }
+ elsif ($num_extra != 0) {
+ $exit_code = 255;
+ }
+ elsif (!$passed) {
+ $exit_code = 255;
+ }
+
+ $$new ||= $exit_code;
+ return;
+}
+
+# Some things used this even though it was private... I am looking at you
+# Test::Builder::Prefix...
+sub _print_comment {
+ my( $self, $fh, @msgs ) = @_;
+
+ return if $self->no_diag;
+ return unless @msgs;
+
+ # Prevent printing headers when compiling (i.e. -c)
+ return if $^C;
+
+ # Smash args together like print does.
+ # Convert undef to 'undef' so its readable.
+ my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
+
+ # Escape the beginning, _print will take care of the rest.
+ $msg =~ s/^/# /;
+
+ local( $\, $", $, ) = ( undef, ' ', '' );
+ print $fh $msg;
+
+ return 0;
+}
+
+# This is used by Test::SharedFork to turn on IPC after the fact. Not
+# documenting because I do not want it used. The method name is borrowed from
+# Test::Builder 2
+# Once Test2 stuff goes stable this method will be removed and Test::SharedFork
+# will be made smarter.
+sub coordinate_forks {
+ my $self = shift;
+
+ {
+ local ($@, $!);
+ require Test2::IPC;
+ }
+ Test2::IPC->import;
+ Test2::API::test2_ipc_enable_polling();
+ Test2::API::test2_load();
+ my $ipc = Test2::IPC::apply_ipc($self->{Stack});
+ $ipc->set_no_fatal(1);
+ Test2::API::test2_no_wait(1);
+}
+
+sub no_log_results { $_[0]->{no_log_results} = 1 }
+
+1;
+
+__END__
+
+=head1 NAME
+
+Test::Builder - Backend for building test libraries
+
+=head1 SYNOPSIS
+
+ package My::Test::Module;
+ use base 'Test::Builder::Module';
+
+ my $CLASS = __PACKAGE__;
+
+ sub ok {
+ my($test, $name) = @_;
+ my $tb = $CLASS->builder;
+
+ $tb->ok($test, $name);
+ }
+
+
+=head1 DESCRIPTION
+
+L<Test::Simple> and L<Test::More> have proven to be popular testing modules,
+but they're not always flexible enough. Test::Builder provides a
+building block upon which to write your own test libraries I<which can
+work together>.
+
+=head2 Construction
+
+=over 4
+
+=item B<new>
+
+ my $Test = Test::Builder->new;
+
+Returns a Test::Builder object representing the current state of the
+test.
+
+Since you only run one test per program C<new> always returns the same
+Test::Builder object. No matter how many times you call C<new()>, you're
+getting the same object. This is called a singleton. This is done so that
+multiple modules share such global information as the test counter and
+where test output is going.
+
+If you want a completely new Test::Builder object different from the
+singleton, use C<create>.
+
+=item B<create>
+
+ my $Test = Test::Builder->create;
+
+Ok, so there can be more than one Test::Builder object and this is how
+you get it. You might use this instead of C<new()> if you're testing
+a Test::Builder based module, but otherwise you probably want C<new>.
+
+B<NOTE>: the implementation is not complete. C<level>, for example, is still
+shared by B<all> Test::Builder objects, even ones created using this method.
+Also, the method name may change in the future.
+
+=item B<subtest>
+
+ $builder->subtest($name, \&subtests, @args);
+
+See documentation of C<subtest> in Test::More.
+
+C<subtest> also, and optionally, accepts arguments which will be passed to the
+subtests reference.
+
+=item B<name>
+
+ diag $builder->name;
+
+Returns the name of the current builder. Top level builders default to C<$0>
+(the name of the executable). Child builders are named via the C<child>
+method. If no name is supplied, will be named "Child of $parent->name".
+
+=item B<reset>
+
+ $Test->reset;
+
+Reinitializes the Test::Builder singleton to its original state.
+Mostly useful for tests run in persistent environments where the same
+test might be run multiple times in the same process.
+
+=back
+
+=head2 Setting up tests
+
+These methods are for setting up tests and declaring how many there
+are. You usually only want to call one of these methods.
+
+=over 4
+
+=item B<plan>
+
+ $Test->plan('no_plan');
+ $Test->plan( skip_all => $reason );
+ $Test->plan( tests => $num_tests );
+
+A convenient way to set up your tests. Call this and Test::Builder
+will print the appropriate headers and take the appropriate actions.
+
+If you call C<plan()>, don't call any of the other methods below.
+
+=item B<expected_tests>
+
+ my $max = $Test->expected_tests;
+ $Test->expected_tests($max);
+
+Gets/sets the number of tests we expect this test to run and prints out
+the appropriate headers.
+
+
+=item B<no_plan>
+
+ $Test->no_plan;
+
+Declares that this test will run an indeterminate number of tests.
+
+
+=item B<done_testing>
+
+ $Test->done_testing();
+ $Test->done_testing($num_tests);
+
+Declares that you are done testing, no more tests will be run after this point.
+
+If a plan has not yet been output, it will do so.
- $ctx->_diag($msg);
- return;
-}
+$num_tests is the number of tests you planned to run. If a numbered
+plan was already declared, and if this contradicts, a failing test
+will be run to reflect the planning mistake. If C<no_plan> was declared,
+this will override.
-sub note {
- my $self = shift;
- my $msg = join '', map { defined($_) ? $_ : 'undef' } @_;
+If C<done_testing()> is called twice, the second call will issue a
+failing test.
- my $ctx = $CTX || Test::Stream::Context->peek || $self->ctx();
- WARN_OF_OVERRIDE(note => $ctx);
+If C<$num_tests> is omitted, the number of tests run will be used, like
+no_plan.
- $ctx->_note($msg);
-}
+C<done_testing()> is, in effect, used when you'd want to use C<no_plan>, but
+safer. You'd use it like so:
-#############################
-# }}} Base Event Producers #
-#############################
+ $Test->ok($a == $b);
+ $Test->done_testing();
-#######################
-# {{{ Public helpers #
-#######################
+Or to plan a variable number of tests:
-sub explain {
- my $self = shift;
+ for my $test (@tests) {
+ $Test->ok($test);
+ }
+ $Test->done_testing(scalar @tests);
- return map {
- ref $_
- ? do {
- protect { require Data::Dumper };
- my $dumper = Data::Dumper->new( [$_] );
- $dumper->Indent(1)->Terse(1);
- $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
- $dumper->Dump;
- }
- : $_
- } @_;
-}
-sub carp {
- my $self = shift;
- $self->ctx->alert(join '' => @_);
-}
+=item B<has_plan>
-sub croak {
- my $self = shift;
- $self->ctx->throw(join '' => @_);
-}
+ $plan = $Test->has_plan
-sub has_plan {
- my $self = shift;
+Find out whether a plan has been defined. C<$plan> is either C<undef> (no plan
+has been set), C<no_plan> (indeterminate # of tests) or an integer (the number
+of expected tests).
- my $plan = $self->ctx->stream->plan || return undef;
- return 'no_plan' if $plan->directive && $plan->directive eq 'NO PLAN';
- return $plan->max;
-}
+=item B<skip_all>
-sub reset {
- my $self = shift;
- my %params = @_;
+ $Test->skip_all;
+ $Test->skip_all($reason);
- $self->{use_shared} = 1 if $params{shared_stream};
+Skips all the tests, using the given C<$reason>. Exits immediately with 0.
- if ($self->{use_shared}) {
- Test::Stream->shared->_reset;
- Test::Stream->shared->state->[-1]->[STATE_LEGACY] = [];
- }
- else {
- $self->{stream} = Test::Stream->new();
- $self->{stream}->set_use_legacy(1);
- $self->{stream}->state->[-1]->[STATE_LEGACY] = [];
- }
+=item B<exported_to>
- # We leave this a global because it has to be localized and localizing
- # hash keys is just asking for pain. Also, it was documented.
- $Level = 1;
+ my $pack = $Test->exported_to;
+ $Test->exported_to($pack);
- $self->{Name} = $0;
+Tells Test::Builder what package you exported your functions to.
- $self->{Original_Pid} = $$;
- $self->{Child_Name} = undef;
+This method isn't terribly useful since modules which share the same
+Test::Builder object might get exported to different packages and only
+the last one will be honored.
- $self->{Exported_To} = undef;
+=back
- $self->{Todo} = undef;
- $self->{Todo_Stack} = [];
- $self->{Start_Todo} = 0;
- $self->{Opened_Testhandles} = 0;
+=head2 Running tests
- return;
-}
+These actually run the tests, analogous to the functions in Test::More.
-#######################
-# }}} Public helpers #
-#######################
+They all return true if the test passed, false if the test failed.
-#################################
-# {{{ Advanced Event Producers #
-#################################
+C<$name> is always optional.
-sub cmp_ok {
- my( $self, $got, $type, $expect, $name ) = @_;
- my $ctx = $self->ctx;
- my ($ok, @diag) = tmt->cmp_check($got, $type, $expect);
- $ctx->ok($ok, $name, \@diag);
- return $ok;
-}
+=over 4
-sub is_eq {
- my( $self, $got, $expect, $name ) = @_;
- my $ctx = $self->ctx;
- my ($ok, @diag) = tmt->is_eq($got, $expect);
- $ctx->ok($ok, $name, \@diag);
- return $ok;
-}
+=item B<ok>
-sub is_num {
- my( $self, $got, $expect, $name ) = @_;
- my $ctx = $self->ctx;
- my ($ok, @diag) = tmt->is_num($got, $expect);
- $ctx->ok($ok, $name, \@diag);
- return $ok;
-}
+ $Test->ok($test, $name);
-sub isnt_eq {
- my( $self, $got, $dont_expect, $name ) = @_;
- my $ctx = $self->ctx;
- my ($ok, @diag) = tmt->isnt_eq($got, $dont_expect);
- $ctx->ok($ok, $name, \@diag);
- return $ok;
-}
+Your basic test. Pass if C<$test> is true, fail if $test is false. Just
+like Test::Simple's C<ok()>.
-sub isnt_num {
- my( $self, $got, $dont_expect, $name ) = @_;
- my $ctx = $self->ctx;
- my ($ok, @diag) = tmt->isnt_num($got, $dont_expect);
- $ctx->ok($ok, $name, \@diag);
- return $ok;
-}
+=item B<is_eq>
-sub like {
- my( $self, $thing, $regex, $name ) = @_;
- my $ctx = $self->ctx;
- my ($ok, @diag) = tmt->regex_check($thing, $regex, '=~');
- $ctx->ok($ok, $name, \@diag);
- return $ok;
-}
+ $Test->is_eq($got, $expected, $name);
-sub unlike {
- my( $self, $thing, $regex, $name ) = @_;
- my $ctx = $self->ctx;
- my ($ok, @diag) = tmt->regex_check($thing, $regex, '!~');
- $ctx->ok($ok, $name, \@diag);
- return $ok;
-}
+Like Test::More's C<is()>. Checks if C<$got eq $expected>. This is the
+string version.
-#################################
-# }}} Advanced Event Producers #
-#################################
+C<undef> only ever matches another C<undef>.
-################################################
-# {{{ Misc #
-################################################
+=item B<is_num>
-sub _new_fh {
- my $self = shift;
- my($file_or_fh) = shift;
+ $Test->is_num($got, $expected, $name);
- return $file_or_fh if $self->is_fh($file_or_fh);
+Like Test::More's C<is()>. Checks if C<$got == $expected>. This is the
+numeric version.
- my $fh;
- if( ref $file_or_fh eq 'SCALAR' ) {
- open $fh, ">>", $file_or_fh
- or croak("Can't open scalar ref $file_or_fh: $!");
- }
- else {
- open $fh, ">", $file_or_fh
- or croak("Can't open test output log $file_or_fh: $!");
- Test::Stream::IOSets->_autoflush($fh);
- }
+C<undef> only ever matches another C<undef>.
- return $fh;
-}
+=item B<isnt_eq>
-sub output {
- my $self = shift;
- my $handles = $self->ctx->stream->io_sets->init_encoding('legacy');
- $handles->[0] = $self->_new_fh(@_) if @_;
- return $handles->[0];
-}
+ $Test->isnt_eq($got, $dont_expect, $name);
-sub failure_output {
- my $self = shift;
- my $handles = $self->ctx->stream->io_sets->init_encoding('legacy');
- $handles->[1] = $self->_new_fh(@_) if @_;
- return $handles->[1];
-}
+Like L<Test::More>'s C<isnt()>. Checks if C<$got ne $dont_expect>. This is
+the string version.
-sub todo_output {
- my $self = shift;
- my $handles = $self->ctx->stream->io_sets->init_encoding('legacy');
- $handles->[2] = $self->_new_fh(@_) if @_;
- return $handles->[2] || $handles->[0];
-}
+=item B<isnt_num>
-sub reset_outputs {
- my $self = shift;
- my $ctx = $self->ctx;
- $ctx->stream->io_sets->reset_legacy;
-}
+ $Test->isnt_num($got, $dont_expect, $name);
-sub use_numbers {
- my $self = shift;
- my $ctx = $self->ctx;
- $ctx->stream->set_use_numbers(@_) if @_;
- $ctx->stream->use_numbers;
-}
+Like L<Test::More>'s C<isnt()>. Checks if C<$got ne $dont_expect>. This is
+the numeric version.
-sub no_ending {
- my $self = shift;
- my $ctx = $self->ctx;
- $ctx->stream->set_no_ending(@_) if @_;
- $ctx->stream->no_ending || 0;
-}
+=item B<like>
-sub no_header {
- my $self = shift;
- my $ctx = $self->ctx;
- $ctx->stream->set_no_header(@_) if @_;
- $ctx->stream->no_header || 0;
-}
+ $Test->like($thing, qr/$regex/, $name);
+ $Test->like($thing, '/$regex/', $name);
-sub no_diag {
- my $self = shift;
- my $ctx = $self->ctx;
- $ctx->stream->set_no_diag(@_) if @_;
- $ctx->stream->no_diag || 0;
-}
+Like L<Test::More>'s C<like()>. Checks if $thing matches the given C<$regex>.
-sub exported_to {
- my($self, $pack) = @_;
- $self->{Exported_To} = $pack if defined $pack;
- return $self->{Exported_To};
-}
+=item B<unlike>
-sub is_fh {
- my $self = shift;
- my $maybe_fh = shift;
- return 0 unless defined $maybe_fh;
+ $Test->unlike($thing, qr/$regex/, $name);
+ $Test->unlike($thing, '/$regex/', $name);
- return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
- return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
+Like L<Test::More>'s C<unlike()>. Checks if $thing B<does not match> the
+given C<$regex>.
- my $out;
- protect {
- $out = eval { $maybe_fh->isa("IO::Handle") }
- || eval { tied($maybe_fh)->can('TIEHANDLE') };
- };
+=item B<cmp_ok>
- return $out;
-}
+ $Test->cmp_ok($thing, $type, $that, $name);
-sub BAILOUT { goto &BAIL_OUT }
+Works just like L<Test::More>'s C<cmp_ok()>.
-sub expected_tests {
- my $self = shift;
+ $Test->cmp_ok($big_num, '!=', $other_big_num);
- my $ctx = $self->ctx;
- $ctx->plan(@_) if @_;
+=back
- my $plan = $ctx->stream->state->[-1]->[STATE_PLAN] || return 0;
- return $plan->max || 0;
-}
+=head2 Other Testing Methods
-sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
- my $self = shift;
+These are methods which are used in the course of writing a test but are not themselves tests.
- my $ctx = $self->ctx;
+=over 4
- return wantarray ? $ctx->call : $ctx->package;
-}
+=item B<BAIL_OUT>
-sub level {
- my( $self, $level ) = @_;
- $Level = $level if defined $level;
- return $Level;
-}
+ $Test->BAIL_OUT($reason);
-sub maybe_regex {
- my ($self, $regex) = @_;
- return is_regex($regex);
-}
+Indicates to the L<Test::Harness> that things are going so badly all
+testing should terminate. This includes running any additional test
+scripts.
-sub is_passing {
- my $self = shift;
- my $ctx = $self->ctx;
- $ctx->stream->is_passing(@_);
-}
+It will exit with 255.
-# Yeah, this is not efficient, but it is only legacy support, barely anything
-# uses it, and they really should not.
-sub current_test {
- my $self = shift;
+=for deprecated
+BAIL_OUT() used to be BAILOUT()
- my $ctx = $self->ctx;
+=item B<skip>
- if (@_) {
- my ($num) = @_;
- my $state = $ctx->stream->state->[-1];
- $state->[STATE_COUNT] = $num;
-
- my $old = $state->[STATE_LEGACY] || [];
- my $new = [];
-
- my $nctx = $ctx->snapshot;
- $nctx->set_todo('incrementing test number');
- $nctx->set_in_todo(1);
-
- for (1 .. $num) {
- my $i;
- $i = shift @$old while @$old && (!$i || !$i->isa('Test::Stream::Event::Ok'));
- $i ||= Test::Stream::Event::Ok->new(
- $nctx,
- [CORE::caller()],
- 0,
- undef,
- undef,
- undef,
- 1,
- );
-
- push @$new => $i;
- }
+ $Test->skip;
+ $Test->skip($why);
- $state->[STATE_LEGACY] = $new;
- }
+Skips the current test, reporting C<$why>.
- $ctx->stream->count;
-}
+=item B<todo_skip>
-sub details {
- my $self = shift;
- my $ctx = $self->ctx;
- my $state = $ctx->stream->state->[-1];
- my @out;
- return @out unless $state->[STATE_LEGACY];
+ $Test->todo_skip;
+ $Test->todo_skip($why);
- for my $e (@{$state->[STATE_LEGACY]}) {
- next unless $e && $e->isa('Test::Stream::Event::Ok');
- push @out => $e->to_legacy;
- }
+Like C<skip()>, only it will declare the test as failing and TODO. Similar
+to
- return @out;
-}
+ print "not ok $tnum # TODO $why\n";
-sub summary {
- my $self = shift;
- my $ctx = $self->ctx;
- my $state = $ctx->stream->state->[-1];
- return @{[]} unless $state->[STATE_LEGACY];
- return map { $_->isa('Test::Stream::Event::Ok') ? ($_->bool ? 1 : 0) : ()} @{$state->[STATE_LEGACY]};
-}
+=begin _unimplemented
-###################################
-# }}} Misc #
-###################################
+=item B<skip_rest>
-####################
-# {{{ TB1.5 stuff #
-####################
+ $Test->skip_rest;
+ $Test->skip_rest($reason);
-# This is just a list of method Test::Builder current does not have that Test::Builder 1.5 does.
-my %TB15_METHODS = map { $_ => 1 } qw{
- _file_and_line _join_message _make_default _my_exit _reset_todo_state
- _result_to_hash _results _todo_state formatter history in_test
- no_change_exit_code post_event post_result set_formatter set_plan test_end
- test_exit_code test_start test_state
-};
+Like C<skip()>, only it skips all the rest of the tests you plan to run
+and terminates the test.
-our $AUTOLOAD;
+If you're running under C<no_plan>, it skips once and terminates the
+test.
-sub AUTOLOAD {
- $AUTOLOAD =~ m/^(.*)::([^:]+)$/;
- my ($package, $sub) = ($1, $2);
+=end _unimplemented
- my @caller = CORE::caller();
- my $msg = qq{Can't locate object method "$sub" via package "$package" at $caller[1] line $caller[2].\n};
+=back
- $msg .= <<" EOT" if $TB15_METHODS{$sub};
- *************************************************************************
- '$sub' is a Test::Builder 1.5 method. Test::Builder 1.5 is a dead branch.
- You need to update your code so that it no longer treats Test::Builders
- over a specific version number as anything special.
+=head2 Test building utility methods
- See: http://blogs.perl.org/users/chad_exodist_granum/2014/03/testmore---new-maintainer-also-stop-version-checking.html
- *************************************************************************
- EOT
+These methods are useful when writing your own test methods.
- die $msg;
-}
+=over 4
-####################
-# }}} TB1.5 stuff #
-####################
+=item B<maybe_regex>
-##################################
-# {{{ Legacy support, do not use #
-##################################
+ $Test->maybe_regex(qr/$regex/);
+ $Test->maybe_regex('/$regex/');
-# These are here to support old versions of Test::More which may be bundled
-# with some dists. See https://github.com/Test-More/test-more/issues/479
+This method used to be useful back when Test::Builder worked on Perls
+before 5.6 which didn't have qr//. Now its pretty useless.
-sub _try {
- my( $self, $code, %opts ) = @_;
+Convenience method for building testing functions that take regular
+expressions as arguments.
- my $error;
- my $return;
- {
- local $!; # eval can mess up $!
- local $@; # don't set $@ in the test
- local $SIG{__DIE__}; # don't trip an outside DIE handler.
- $return = eval { $code->() };
- $error = $@;
- }
+Takes a quoted regular expression produced by C<qr//>, or a string
+representing a regular expression.
- die $error if $error and $opts{die_on_fail};
+Returns a Perl value which may be used instead of the corresponding
+regular expression, or C<undef> if its argument is not recognized.
- return wantarray ? ( $return, $error ) : $return;
-}
+For example, a version of C<like()>, sans the useful diagnostic messages,
+could be written as:
-sub _unoverload {
- my $self = shift;
- my $type = shift;
+ sub laconic_like {
+ my ($self, $thing, $regex, $name) = @_;
+ my $usable_regex = $self->maybe_regex($regex);
+ die "expecting regex, found '$regex'\n"
+ unless $usable_regex;
+ $self->ok($thing =~ m/$usable_regex/, $name);
+ }
- $self->_try(sub { require overload; }, die_on_fail => 1);
- foreach my $thing (@_) {
- if( $self->_is_object($$thing) ) {
- if( my $string_meth = overload::Method( $$thing, $type ) ) {
- $$thing = $$thing->$string_meth();
- }
- }
- }
+=item B<is_fh>
- return;
-}
+ my $is_fh = $Test->is_fh($thing);
-sub _is_object {
- my( $self, $thing ) = @_;
+Determines if the given C<$thing> can be used as a filehandle.
- return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
-}
+=cut
-sub _unoverload_str {
- my $self = shift;
- return $self->_unoverload( q[""], @_ );
-}
+=back
-sub _unoverload_num {
- my $self = shift;
- $self->_unoverload( '0+', @_ );
+=head2 Test style
- for my $val (@_) {
- next unless $self->_is_dualvar($$val);
- $$val = $$val + 0;
- }
- return;
-}
+=over 4
-# This is a hack to detect a dualvar such as $!
-sub _is_dualvar {
- my( $self, $val ) = @_;
+=item B<level>
- # Objects are not dualvars.
- return 0 if ref $val;
+ $Test->level($how_high);
- no warnings 'numeric';
- my $numval = $val + 0;
- return ($numval != 0 and $numval ne $val ? 1 : 0);
-}
+How far up the call stack should C<$Test> look when reporting where the
+test failed.
-##################################
-# }}} Legacy support, do not use #
-##################################
+Defaults to 1.
-1;
+Setting C<$Test::Builder::Level> overrides. This is typically useful
+localized:
-__END__
+ sub my_ok {
+ my $test = shift;
-=pod
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ $TB->ok($test);
+ }
-=head1 NAME
+To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant.
-Test::Builder - *DEPRECATED* Module for building testing libraries.
+=item B<use_numbers>
-=head1 DESCRIPTION
+ $Test->use_numbers($on_or_off);
-This module was previously the base module for almost any testing library. This
-module is now little more than a compatability wrapper around L<Test::Stream>.
-If you are looking to write or update a testing library you should look at
-L<Test::Stream::Toolset>.
+Whether or not the test should output numbers. That is, this if true:
-=head1 PACKAGE VARS
+ ok 1
+ ok 2
+ ok 3
-=over 4
+or this if false
-=item $Test::Builder::Test
+ ok
+ ok
+ ok
-The variable that holds the Test::Builder singleton.
+Most useful when you can't depend on the test output order, such as
+when threads or forking is involved.
-=item $Test::Builder::Level
+Defaults to on.
-In the past this variable was used to track stack depth so that Test::Builder
-could report the correct line number. If you use Test::Builder this will still
-work, but in new code it is better to use the L<Test::Stream::Context> module.
+=item B<no_diag>
-=back
+ $Test->no_diag($no_diag);
-=head1 METHODS
+If set true no diagnostics will be printed. This includes calls to
+C<diag()>.
-=head2 CONSTRUCTORS
+=item B<no_ending>
-=over 4
+ $Test->no_ending($no_ending);
-=item Test::Builder->new
+Normally, Test::Builder does some extra diagnostics when the test
+ends. It also changes the exit code as described below.
-Returns the singleton stored in C<$Test::Builder::Test>.
+If this is true, none of that will be done.
-=item Test::Builder->create
+=item B<no_header>
-=item Test::Builder->create(use_shared => 1)
+ $Test->no_header($no_header);
-Returns a new instance of Test::Builder. It is important to note that this
-instance will not use the shared L<Test::Stream> object unless you pass in the
-C<< use_shared => 1 >> argument.
+If set to true, no "1..N" header will be printed.
=back
-=head2 UTIL
+=head2 Output
-=over 4
+Controlling where the test output goes.
-=item $TB->ctx
+It's ok for your test to change where STDOUT and STDERR point to,
+Test::Builder's default output settings will not be affected.
-Helper method for Test::Builder to get a L<Test::Stream::Context> object.
+=over 4
-=item $TB->depth
+=item B<diag>
-Get the subtest depth
+ $Test->diag(@msgs);
-=item $TB->find_TODO
+Prints out the given C<@msgs>. Like C<print>, arguments are simply
+appended together.
-=item $TB->in_todo
+Normally, it uses the C<failure_output()> handle, but if this is for a
+TODO test, the C<todo_output()> handle is used.
-=item $TB->todo
+Output will be indented and marked with a # so as not to interfere
+with test output. A newline will be put on the end if there isn't one
+already.
-These all check on todo state and value
+We encourage using this rather than calling print directly.
-=back
+Returns false. Why? Because C<diag()> is often used in conjunction with
+a failing test (C<ok() || diag()>) it "passes through" the failure.
-=head2 OTHER
+ return ok(...) || diag(...);
-=over 4
+=for blame transfer
+Mark Fowler <mark@twoshortplanks.com>
-=item $TB->caller
+=item B<note>
-=item $TB->carp
+ $Test->note(@msgs);
-=item $TB->croak
+Like C<diag()>, but it prints to the C<output()> handle so it will not
+normally be seen by the user except in verbose mode.
-These let you figure out when/where the test is defined in the test file.
+=item B<explain>
-=item $TB->child
+ my @dump = $Test->explain(@msgs);
-Start a subtest (Please do not use this)
+Will dump the contents of any references in a human readable format.
+Handy for things like...
-=item $TB->finalize
+ is_deeply($have, $want) || diag explain $have;
-Finish a subtest (Please do not use this)
+or
-=item $TB->explain
+ is_deeply($have, $want) || note explain $have;
-Interface to Data::Dumper that dumps whatever you give it.
+=item B<output>
-=item $TB->exported_to
+=item B<failure_output>
-This used to tell you what package used Test::Builder, it never worked well.
-The previous bad and unpredictable behavior of this has largely been preserved,
-however nothing internal uses it in any meaningful way anymore.
+=item B<todo_output>
-=item $TB->is_fh
+ my $filehandle = $Test->output;
+ $Test->output($filehandle);
+ $Test->output($filename);
+ $Test->output(\$scalar);
-Check if something is a filehandle
+These methods control where Test::Builder will print its output.
+They take either an open C<$filehandle>, a C<$filename> to open and write to
+or a C<$scalar> reference to append to. It will always return a C<$filehandle>.
-=item $TB->level
+B<output> is where normal "ok/not ok" test output goes.
-Get/Set C<$Test::Builder::Level>. $Level is a package var, and most thigns
-localize it, so this method is pretty useless.
+Defaults to STDOUT.
-=item $TB->maybe_regex
+B<failure_output> is where diagnostic output on test failures and
+C<diag()> goes. It is normally not read by Test::Harness and instead is
+displayed to the user.
-Check if something might be a regex.
+Defaults to STDERR.
-=item $TB->reset
+C<todo_output> is used instead of C<failure_output()> for the
+diagnostics of a failing TODO test. These will not be seen by the
+user.
-Reset the builder object to a very basic and default state. You almost
-certainly do not need this unless you are writing a tool to test testing
-libraries. Even then you probably do not want this.
+Defaults to STDOUT.
-=item $TB->todo_end
+=item reset_outputs
-=item $TB->todo_start
+ $tb->reset_outputs;
-Start/end TODO state, there are better ways to do this now.
+Resets all the output filehandles back to their defaults.
-=back
+=item carp
-=head2 STREAM INTERFACE
+ $tb->carp(@message);
-These simply interface into functionality of L<Test::Stream>.
+Warns with C<@message> but the message will appear to come from the
+point where the original test function was called (C<< $tb->caller >>).
-=over 4
+=item croak
-=item $TB->failure_output
+ $tb->croak(@message);
-=item $TB->output
+Dies with C<@message> but the message will appear to come from the
+point where the original test function was called (C<< $tb->caller >>).
-=item $TB->reset_outputs
-=item $TB->todo_output
+=back
-These get/set the IO handle used in the 'legacy' tap encoding.
-=item $TB->no_diag
+=head2 Test Status and Info
-Do not display L<Test::Stream::Event::Diag> events.
+=over 4
-=item $TB->no_ending
+=item B<no_log_results>
-Do not do some special magic at the end that tells you what went wrong with
-tests.
+This will turn off result long-term storage. Calling this method will make
+C<details> and C<summary> useless. You may want to use this if you are running
+enough tests to fill up all available memory.
-=item $TB->no_header
+ Test::Builder->new->no_log_results();
-Do not display the plan
+There is no way to turn it back on.
-=item $TB->use_numbers
+=item B<current_test>
-Turn numbers in TAP on and off.
+ my $curr_test = $Test->current_test;
+ $Test->current_test($num);
-=back
+Gets/sets the current test number we're on. You usually shouldn't
+have to set this.
-=head2 HISTORY
+If set forward, the details of the missing tests are filled in as 'unknown'.
+if set backward, the details of the intervening tests are deleted. You
+can erase history if you really want to.
-=over
-=item $TB->details
+=item B<is_passing>
-Get all the events that occured on this object. Each event will be transformed
-into a hash that matches the legacy output of this method.
+ my $ok = $builder->is_passing;
-=item $TB->expected_tests
+Indicates if the test suite is currently passing.
-Set/Get expected number of tests
+More formally, it will be false if anything has happened which makes
+it impossible for the test suite to pass. True otherwise.
-=item $TB->has_plan
+For example, if no tests have run C<is_passing()> will be true because
+even though a suite with no tests is a failure you can add a passing
+test to it and start passing.
-Check if there is a plan
+Don't think about it too much.
-=item $TB->summary
-List of pass/fail results.
+=item B<summary>
-=back
+ my @tests = $Test->summary;
-=head2 EVENT GENERATORS
+A simple summary of the tests so far. True for pass, false for fail.
+This is a logical pass/fail, so todos are passes.
-See L<Test::Stream::Context>, L<Test::Stream::Toolset>, and
-L<Test::More::Tools>. Calling the methods below is not advised.
+Of course, test #1 is $tests[0], etc...
-=over 4
-=item $TB->BAILOUT
+=item B<details>
-=item $TB->BAIL_OUT
+ my @tests = $Test->details;
-=item $TB->cmp_ok
+Like C<summary()>, but with a lot more detail.
-=item $TB->current_test
+ $tests[$test_num - 1] =
+ { 'ok' => is the test considered a pass?
+ actual_ok => did it literally say 'ok'?
+ name => name of the test (if any)
+ type => type of test (if any, see below).
+ reason => reason for the above (if any)
+ };
-=item $TB->diag
+'ok' is true if Test::Harness will consider the test to be a pass.
-=item $TB->done_testing
+'actual_ok' is a reflection of whether or not the test literally
+printed 'ok' or 'not ok'. This is for examining the result of 'todo'
+tests.
-=item $TB->is_eq
+'name' is the name of the test.
-=item $TB->is_num
+'type' indicates if it was a special test. Normal tests have a type
+of ''. Type can be one of the following:
-=item $TB->is_passing
+ skip see skip()
+ todo see todo()
+ todo_skip see todo_skip()
+ unknown see below
-=item $TB->isnt_eq
+Sometimes the Test::Builder test counter is incremented without it
+printing any test output, for example, when C<current_test()> is changed.
+In these cases, Test::Builder doesn't know the result of the test, so
+its type is 'unknown'. These details for these tests are filled in.
+They are considered ok, but the name and actual_ok is left C<undef>.
-=item $TB->isnt_num
+For example "not ok 23 - hole count # TODO insufficient donuts" would
+result in this structure:
-=item $TB->like
+ $tests[22] = # 23 - 1, since arrays start from 0.
+ { ok => 1, # logically, the test passed since its todo
+ actual_ok => 0, # in absolute terms, it failed
+ name => 'hole count',
+ type => 'todo',
+ reason => 'insufficient donuts'
+ };
-=item $TB->no_plan
-=item $TB->note
+=item B<todo>
-=item $TB->ok
+ my $todo_reason = $Test->todo;
+ my $todo_reason = $Test->todo($pack);
-=item $TB->plan
+If the current tests are considered "TODO" it will return the reason,
+if any. This reason can come from a C<$TODO> variable or the last call
+to C<todo_start()>.
-=item $TB->skip
+Since a TODO test does not need a reason, this function can return an
+empty string even when inside a TODO block. Use C<< $Test->in_todo >>
+to determine if you are currently inside a TODO block.
-=item $TB->skip_all
+C<todo()> is about finding the right package to look for C<$TODO> in. It's
+pretty good at guessing the right package to look at. It first looks for
+the caller based on C<$Level + 1>, since C<todo()> is usually called inside
+a test function. As a last resort it will use C<exported_to()>.
-=item $TB->subtest
+Sometimes there is some confusion about where C<todo()> should be looking
+for the C<$TODO> variable. If you want to be sure, tell it explicitly
+what $pack to use.
-=item $TB->todo_skip
+=item B<find_TODO>
-=item $TB->unlike
+ my $todo_reason = $Test->find_TODO();
+ my $todo_reason = $Test->find_TODO($pack);
-=back
+Like C<todo()> but only returns the value of C<$TODO> ignoring
+C<todo_start()>.
-=head2 ACCESSORS
+Can also be used to set C<$TODO> to a new value while returning the
+old value:
-=over 4
+ my $old_reason = $Test->find_TODO($pack, 1, $new_reason);
-=item $TB->stream
+=item B<in_todo>
-Get the stream used by this builder (or the shared stream).
+ my $in_todo = $Test->in_todo;
-=item $TB->name
+Returns true if the test is currently inside a TODO block.
-Name of the test
+=item B<todo_start>
-=item $TB->parent
+ $Test->todo_start();
+ $Test->todo_start($message);
-Parent if this is a child.
+This method allows you declare all subsequent tests as TODO tests, up until
+the C<todo_end> method has been called.
-=back
+The C<TODO:> and C<$TODO> syntax is generally pretty good about figuring out
+whether or not we're in a TODO test. However, often we find that this is not
+possible to determine (such as when we want to use C<$TODO> but
+the tests are being executed in other packages which can't be inferred
+beforehand).
-=head1 MONKEYPATCHING
+Note that you can use this to nest "todo" tests
-Many legacy testing modules monkeypatch C<ok()>, C<plan()>, and others. The
-abillity to monkeypatch these to effect all events of the specified type is now
-considered discouraged. For backwords compatability monkeypatching continues to
-work, however in the distant future it will be removed. L<Test::Stream> upon
-which Test::Builder is now built, provides hooks and API's for doing everything
-that previously required monkeypatching.
+ $Test->todo_start('working on this');
+ # lots of code
+ $Test->todo_start('working on that');
+ # more code
+ $Test->todo_end;
+ $Test->todo_end;
-=encoding utf8
+This is generally not recommended, but large testing systems often have weird
+internal needs.
-=head1 TUTORIALS
+We've tried to make this also work with the TODO: syntax, but it's not
+guaranteed and its use is also discouraged:
-=over 4
+ TODO: {
+ local $TODO = 'We have work to do!';
+ $Test->todo_start('working on this');
+ # lots of code
+ $Test->todo_start('working on that');
+ # more code
+ $Test->todo_end;
+ $Test->todo_end;
+ }
-=item L<Test::Tutorial>
+Pick one style or another of "TODO" to be on the safe side.
-The original L<Test::Tutorial>. Uses comedy to introduce you to testing from
-scratch.
-=item L<Test::Tutorial::WritingTests>
+=item C<todo_end>
-The L<Test::Tutorial::WritingTests> tutorial takes a more technical approach.
-The idea behind this tutorial is to give you a technical introduction to
-testing that can easily be used as a reference. This is for people who say
-"Just tell me how to do it, and quickly!".
+ $Test->todo_end;
-=item L<Test::Tutorial::WritingTools>
+Stops running tests as "TODO" tests. This method is fatal if called without a
+preceding C<todo_start> method call.
-The L<Test::Tutorial::WritingTools> tutorial is an introduction to writing
-testing tools that play nicely with other L<Test::Stream> and L<Test::Builder>
-based tools. This is what you should look at if you want to write
-Test::MyWidget.
+=item B<caller>
-=back
+ my $package = $Test->caller;
+ my($pack, $file, $line) = $Test->caller;
+ my($pack, $file, $line) = $Test->caller($height);
-=head1 SOURCE
+Like the normal C<caller()>, except it reports according to your C<level()>.
-The source code repository for Test::More can be found at
-F<http://github.com/Test-More/test-more/>.
+C<$height> will be added to the C<level()>.
-=head1 MAINTAINER
+If C<caller()> winds up off the top of the stack it report the highest context.
-=over 4
+=back
-=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+=head1 EXIT CODES
-=back
+If all your tests passed, Test::Builder will exit with zero (which is
+normal). If anything failed it will exit with how many failed. If
+you run less (or more) tests than you planned, the missing (or extras)
+will be considered failures. If no tests were ever run Test::Builder
+will throw a warning and exit with 255. If the test died, even after
+having successfully completed all its tests, it will still be
+considered a failure and will exit with 255.
-=head1 AUTHORS
+So the exit codes are...
-The following people have all contributed to the Test-More dist (sorted using
-VIM's sort function).
+ 0 all tests successful
+ 255 test died or all passed but wrong # of tests run
+ any other number how many failed (including missing or extras)
-=over 4
+If you fail more than 254 tests, it will be reported as 254.
-=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+=head1 THREADS
-=item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
+In perl 5.8.1 and later, Test::Builder is thread-safe. The test number is
+shared by all threads. This means if one thread sets the test number using
+C<current_test()> they will all be effected.
-=item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
+While versions earlier than 5.8.1 had threads they contain too many
+bugs to support.
-=item Michael G Schwern E<lt>schwern@pobox.comE<gt>
+Test::Builder is only thread-aware if threads.pm is loaded I<before>
+Test::Builder.
-=item 唐鳳
+You can directly disable thread support with one of the following:
-=back
+ $ENV{T2_NO_IPC} = 1
-=head1 COPYRIGHT
+or
-There has been a lot of code migration between modules,
-here are all the original copyrights together:
+ no Test2::IPC;
-=over 4
+or
-=item Test::Stream
+ Test2::API::test2_ipc_disable()
-=item Test::Stream::Tester
+=head1 MEMORY
-Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
+An informative hash, accessible via C<details()>, is stored for each
+test you perform. So memory usage will scale linearly with each test
+run. Although this is not a problem for most test suites, it can
+become an issue if you do large (hundred thousands to million)
+combinatorics tests in the same run.
-This program is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
+In such cases, you are advised to either split the test file into smaller
+ones, or use a reverse approach, doing "normal" (code) compares and
+triggering C<fail()> should anything go unexpected.
-See F<http://www.perl.com/perl/misc/Artistic.html>
+Future versions of Test::Builder will have a way to turn history off.
-=item Test::Simple
-=item Test::More
+=head1 EXAMPLES
-=item Test::Builder
+CPAN can provide the best examples. L<Test::Simple>, L<Test::More>,
+L<Test::Exception> and L<Test::Differences> all use Test::Builder.
-Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
-inspiration from Joshua Pritikin's Test module and lots of help from Barrie
-Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
-gang.
+=head1 SEE ALSO
-Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
-E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
+=head2 INTERNALS
-Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+L<Test2>, L<Test2::API>
-This program is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
+=head2 LEGACY
-See F<http://www.perl.com/perl/misc/Artistic.html>
+L<Test::Simple>, L<Test::More>
-=item Test::use::ok
+=head2 EXTERNAL
-To the extent possible under law, 唐鳳 has waived all copyright and related
-or neighboring rights to L<Test-use-ok>.
+L<Test::Harness>
-This work is published from Taiwan.
+=head1 AUTHORS
-L<http://creativecommons.org/publicdomain/zero/1.0>
+Original code by chromatic, maintained by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>
-=item Test::Tester
+=head1 MAINTAINERS
-This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
-are based on other people's work.
+=over 4
-Under the same license as Perl itself
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
-See http://www.perl.com/perl/misc/Artistic.html
+=back
-=item Test::Builder::Tester
+=head1 COPYRIGHT
-Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
+Copyright 2002-2008 by chromatic E<lt>chromatic@wgz.orgE<gt> and
+ Michael G Schwern E<lt>schwern@pobox.comE<gt>.
-This program is free software; you can redistribute it
-and/or modify it under the same terms as Perl itself.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
-=back
+See F<http://www.perl.com/perl/misc/Artistic.html>
https://perl5.git.perl.org / perl5.git / blobdiff