diff options
| author | Karl Berry <karl@freefriends.org> | 2018-03-08 00:16:42 +0000 |
|---|---|---|
| committer | Karl Berry <karl@freefriends.org> | 2018-03-08 00:16:42 +0000 |
| commit | 34a8597760ab5740abd49b6d8be10e1876f5ce98 (patch) | |
| tree | 099a794912a28b3ebbc857961643ba29b28e674a /Master/tlpkg/tlperl/lib/Test | |
| parent | 2ca3610031316a7312d046d3ae4c783452831216 (diff) | |
(tl)perl 5.26.1 from siep
git-svn-id: svn://tug.org/texlive/trunk@46882 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Test')
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Test/Builder.pm | 2982 | ||||
| -rwxr-xr-x | Master/tlpkg/tlperl/lib/Test/Builder/Formatter.pm | 122 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Test/Builder/Module.pm | 10 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Test/Builder/Tester.pm | 69 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Test/Builder/Tester/Color.pm | 2 | ||||
| -rwxr-xr-x | Master/tlpkg/tlperl/lib/Test/Builder/TodoDiag.pm | 61 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Test/Harness.pm | 6 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Test/More.pm | 88 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Test/Simple.pm | 5 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Test/Tester.pm | 20 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Test/Tester/Capture.pm | 18 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Test/Tester/CaptureRunner.pm | 3 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Test/Tester/Delegate.pm | 13 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Test/use/ok.pm | 4 |
14 files changed, 1790 insertions, 1613 deletions
diff --git a/Master/tlpkg/tlperl/lib/Test/Builder.pm b/Master/tlpkg/tlperl/lib/Test/Builder.pm index a8e7bd95b1c..052e2793b91 100644 --- a/Master/tlpkg/tlperl/lib/Test/Builder.pm +++ b/Master/tlpkg/tlperl/lib/Test/Builder.pm @@ -4,8 +4,7 @@ use 5.006; use strict; use warnings; -our $VERSION = '1.001014'; -$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) +our $VERSION = '1.302073'; BEGIN { if( $] < 5.008 ) { @@ -13,516 +12,410 @@ BEGIN { } } +use Scalar::Util qw/blessed reftype weaken/; +use Test2::Util qw/USE_THREADS try get_tid/; +use Test2::API qw/context release/; # Make Test::Builder thread-safe for ithreads. BEGIN { - use Config; - # Load threads::shared when threads are turned on. - # 5.8.0's threads are so busted we no longer support them. - if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) { - require threads::shared; - - # Hack around YET ANOTHER threads::shared bug. It would - # occasionally forget the contents of the variable when sharing it. - # So we first copy the data, then share, then put our copy back. - *share = sub (\[$@%]) { - my $type = ref $_[0]; - my $data; - - if( $type eq 'HASH' ) { - %$data = %{ $_[0] }; - } - elsif( $type eq 'ARRAY' ) { - @$data = @{ $_[0] }; - } - elsif( $type eq 'SCALAR' ) { - $$data = ${ $_[0] }; - } - else { - die( "Unknown type: " . $type ); - } - - $_[0] = &threads::shared::share( $_[0] ); - - if( $type eq 'HASH' ) { - %{ $_[0] } = %$data; - } - elsif( $type eq 'ARRAY' ) { - @{ $_[0] } = @$data; - } - elsif( $type eq 'SCALAR' ) { - ${ $_[0] } = $$data; - } - else { - die( "Unknown type: " . $type ); - } + warn "Test::Builder was loaded after Test2 initialization, this is not recommended." + if Test2::API::test2_init_done() || Test2::API::test2_load_done(); - return $_[0]; - }; - } - # 5.8.0's threads::shared is busted when threads are off - # and earlier Perls just don't have that module at all. - else { - *share = sub { return $_[0] }; - *lock = sub { 0 }; + if (USE_THREADS) { + 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); + Test2::API::test2_ipc_enable_shm(); } } -=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; +use Test2::Event::Subtest; +use Test2::Hub::Subtest; - $tb->ok($test, $name); - } +use Test::Builder::Formatter; +use Test::Builder::TodoDiag; +our $Level = 1; +our $Test = $ENV{TB_NO_EARLY_INIT} ? undef : Test::Builder->new; -=head1 DESCRIPTION +sub _add_ts_hooks { + my $self = shift; + my $hub = $self->{Stack}->top; -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>. + # 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}; -=head2 Construction + #$hub->add_context_aquire(sub {$_[0]->{level} += $Level - 1}); -=over 4 + $hub->pre_filter(sub { + my ($active_hub, $e) = @_; -=item B<new> + my $epkg = $$epkgr; + my $cpkg = $e->{trace} ? $e->{trace}->{frame}->[0] : undef; - my $Test = Test::Builder->new; + no strict 'refs'; + no warnings 'once'; + my $todo; + $todo = ${"$cpkg\::TODO"} if $cpkg; + $todo = ${"$epkg\::TODO"} if $epkg && !$todo; -Returns a Test::Builder object representing the current state of the -test. + return $e unless $todo; -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. + # Turn a diag into a todo diag + return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag'; -If you want a completely new Test::Builder object different from the -singleton, use C<create>. + # Set todo on ok's + if ($e->isa('Test2::Event::Ok')) { + $e->set_todo($todo); + $e->set_effective_pass(1); -=cut + if (my $result = $e->get_meta(__PACKAGE__)) { + $result->{reason} ||= $todo; + $result->{type} ||= 'todo'; + $result->{ok} = 1; + } + } -our $Test = Test::Builder->new; + return $e; + }, inherit => 1); +} sub new { my($class) = shift; - $Test ||= $class->create; - return $Test; -} - -=item B<create> + unless($Test) { + my $ctx = context(); + $Test = $class->create(singleton => 1); + $ctx->release; - 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>. + # 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 }); -B<NOTE>: the implementation is not complete. C<level>, for example, is -still shared amongst B<all> Test::Builder objects, even ones created using -this method. Also, the method name may change in the future. + Test2::API::test2_add_callback_exit(sub { $Test->_ending(@_) }); -=cut + Test2::API::test2_ipc()->set_no_fatal(1) if USE_THREADS; + } + return $Test; +} sub create { my $class = shift; + my %params = @_; my $self = bless {}, $class; - $self->reset; + 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; - _share_keys($dest); - - 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; -=item B<child> - - my $child = $builder->child($name_of_child); - $child->plan( tests => 4 ); - $child->ok(some_code()); - ... - $child->finalize; - -Returns a new instance of C<Test::Builder>. Any output from this child will -be indented four spaces more than the parent's indentation. When done, the -C<finalize> method I<must> be called explicitly. - -Trying to create a new child with a previous child still active (i.e., -C<finalize> not called) will C<croak>. + my $parent = $chub->meta(__PACKAGE__, {})->{parent}; -Trying to run a test when you have an open child will also C<croak> and cause -the test suite to fail. + return undef unless $parent; -=cut + return bless { + Original_Pid => $$, + Stack => $self->{Stack}, + Hub => $parent, + }, blessed($self); +} sub child { my( $self, $name ) = @_; - if( $self->{Child_Name} ) { - $self->croak("You already have a child named ($self->{Child_Name}) running"); - } + $name ||= "Child of " . $self->name; + my $ctx = $self->ctx; - my $parent_in_todo = $self->in_todo; + my $parent = $ctx->hub; + my $pmeta = $parent->meta(__PACKAGE__, {}); + $self->croak("You already have a child named ($pmeta->{child}) running") + if $pmeta->{child}; + + $pmeta->{child} = $name; # Clear $TODO for the child. my $orig_TODO = $self->find_TODO(undef, 1, undef); - my $class = ref $self; - my $child = $class->create; - - # Add to our indentation - $child->_indent( $self->_indent . ' ' ); + my $subevents = []; - # Make the child use the same outputs as the parent - for my $method (qw(output failure_output todo_output)) { - $child->$method( $self->$method ); - } + my $hub = $ctx->stack->new_hub( + class => 'Test2::Hub::Subtest', + ); - # Ensure the child understands if they're inside a TODO - if( $parent_in_todo ) { - $child->failure_output( $self->todo_output ); - } + $hub->pre_filter(sub { + my ($active_hub, $e) = @_; - # This will be reset in finalize. We do this here lest one child failure - # cause all children to fail. - $child->{Child_Error} = $?; - $? = 0; - $child->{Parent} = $self; - $child->{Parent_TODO} = $orig_TODO; - $child->{Name} = $name || "Child of " . $self->name; - $self->{Child_Name} = $child->name; - return $child; -} + # 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; -=item B<subtest> + $hub->listen(sub { push @$subevents => $_[1] }); - $builder->subtest($name, \&subtests, @args); + $hub->set_nested( $parent->isa('Test2::Hub::Subtest') ? $parent->nested + 1 : 1 ); -See documentation of C<subtest> in Test::More. + 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_buffered} = $parent->format ? 0 : 1; -C<subtest> also, and optionally, accepts arguments which will be passed to the -subtests reference. + $self->_add_ts_hooks; -=cut + $ctx->release; + return bless { Original_Pid => $$, Stack => $self->{Stack}, Hub => $hub }, blessed($self); +} -sub subtest { +sub finalize { my $self = shift; - my($name, $subtests, @args) = @_; - - if ('CODE' ne ref $subtests) { - $self->croak("subtest()'s second argument must be a code ref"); - } - - # Turn the child into the parent so anyone who has stored a copy of - # the Test::Builder singleton will get the child. - my $error; - my $child; - my $parent = {}; - { - # child() calls reset() which sets $Level to 1, so we localize - # $Level first to limit the scope of the reset to the subtest. - local $Test::Builder::Level = $Test::Builder::Level + 1; + my $ok = 1; + ($ok) = @_ if @_; - # Store the guts of $self as $parent and turn $child into $self. - $child = $self->child($name); - _copy($self, $parent); - _copy($child, $self); - - my $run_the_subtests = sub { - # Add subtest name for clarification of starting point - $self->note("Subtest: $name"); - $subtests->(@args); - $self->done_testing unless $self->_plan_handled; - 1; - }; + my $st_ctx = $self->ctx; + my $chub = $self->{Hub} || return $st_ctx->release; - if( !eval { $run_the_subtests->() } ) { - $error = $@; - } + my $meta = $chub->meta(__PACKAGE__, {}); + if ($meta->{child}) { + $self->croak("Can't call finalize() with child ($meta->{child}) active"); } - # Restore the parent and the copied child. - _copy($self, $child); - _copy($parent, $self); - - # Restore the parent's $TODO - $self->find_TODO(undef, 1, $child->{Parent_TODO}); - - # Die *after* we restore the parent. - die $error if $error and !eval { $error->isa('Test::Builder::Exception') }; - - local $Test::Builder::Level = $Test::Builder::Level + 1; - my $finalize = $child->finalize; - - $self->BAIL_OUT($child->{Bailed_Out_Reason}) if $child->{Bailed_Out}; - - return $finalize; -} - -=begin _private - -=item B<_plan_handled> - - if ( $Test->_plan_handled ) { ... } - -Returns true if the developer has explicitly handled the plan via: - -=over 4 - -=item * Explicitly setting the number of tests - -=item * Setting 'no_plan' - -=item * Set 'skip_all'. - -=back - -This is currently used in subtests when we implicitly call C<< $Test->done_testing >> -if the developer has not set a plan. - -=end _private - -=cut - -sub _plan_handled { - my $self = shift; - return $self->{Have_Plan} || $self->{No_Plan} || $self->{Skip_All}; -} - - -=item B<finalize> + local $? = 0; # don't fail if $subtests happened to set $? nonzero - my $ok = $child->finalize; + $self->{Stack}->pop($chub); -When your child is done running tests, you must call C<finalize> to clean up -and tell the parent your pass/fail status. + $self->find_TODO($meta->{TODO_PKG}, 1, $meta->{TODO}); -Calling C<finalize> on a child with open children will C<croak>. + my $parent = $self->parent; + my $ctx = $parent->ctx; + my $trace = $ctx->trace; + delete $ctx->hub->meta(__PACKAGE__, {})->{child}; -If the child falls out of scope before C<finalize> is called, a failure -diagnostic will be issued and the child is considered to have failed. + $chub->finalize($trace, 1) + if $ok + && $chub->count + && !$chub->no_ending + && !$chub->ended; -No attempt to call methods on a child after C<finalize> is called is -guaranteed to succeed. + my $plan = $chub->plan || 0; + my $count = $chub->count; + my $failed = $chub->failed; + my $passed = $chub->is_passing; -Calling this on the root builder is a no-op. + 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 + } -=cut + if ($failed) { + my $s = $failed == 1 ? '' : 's'; -sub finalize { - my $self = shift; + my $qualifier = $num_extra == 0 ? '' : ' run'; - return unless $self->parent; - if( $self->{Child_Name} ) { - $self->croak("Can't call finalize() with child ($self->{Child_Name}) active"); + $st_ctx->diag(<<"FAIL"); +Looks like you failed $failed test$s of $count$qualifier. +FAIL } - local $? = 0; # don't fail if $subtests happened to set $? nonzero - $self->_ending; + if (!$passed && !$failed && $count && !$num_extra) { + $st_ctx->diag(<<"FAIL"); +All assertions inside the subtest passed, but errors were encountered. +FAIL + } - # XXX This will only be necessary for TAP envelopes (we think) - #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" ); + $st_ctx->release; - local $Test::Builder::Level = $Test::Builder::Level + 1; - my $ok = 1; - $self->parent->{Child_Name} = undef; - unless ($self->{Bailed_Out}) { - if ( $self->{Skip_All} ) { - $self->parent->skip($self->{Skip_All}, $self->name); + unless ($chub->bailed_out) { + my $plan = $chub->plan; + if ( $plan && $plan eq 'SKIP' ) { + $parent->skip($chub->skip_reason, $meta->{Name}); } - elsif ( not @{ $self->{Test_Results} } ) { - $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name ); + elsif ( !$chub->count ) { + $parent->ok( 0, sprintf q[No tests run for subtest "%s"], $meta->{Name} ); } else { - $self->parent->ok( $self->is_passing, $self->name ); + $parent->{subevents} = $meta->{subevents}; + $parent->{subtest_id} = $meta->{subtest_id}; + $parent->{subtest_buffered} = $meta->{subtest_buffered}; + $parent->ok( $chub->is_passing, $meta->{Name} ); } } - $? = $self->{Child_Error}; - delete $self->{Parent}; - return $self->is_passing; + $ctx->release; + return $chub->is_passing; } -sub _indent { +sub subtest { my $self = shift; - - if( @_ ) { - $self->{Indent} = shift; + my ($name, $code, @args) = @_; + my $ctx = $self->ctx; + $ctx->throw("subtest()'s second argument must be a code ref") + unless $code && reftype($code) eq 'CODE'; + + $name ||= "Child of " . $self->name; + + $ctx->note("Subtest: $name"); + + 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; + } } - return $self->{Indent}; -} - -=item B<parent> + if ($start_pid != $$ && !$INC{'Test/Sync/IPC.pm'}) { + warn $ok ? "Forked inside subtest, but subtest never finished!\n" : $err; + exit 255; + } - if ( my $parent = $builder->parent ) { - ... - } + my $trace = $ctx->trace; -Returns the parent C<Test::Builder> instance, if any. Only used with child -builders for nested TAP. + 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; + } -=cut + my $st_hub = $st_ctx->hub; + my $plan = $st_hub->plan; + my $count = $st_hub->count; -sub parent { shift->{Parent} } + if (!$count && (!defined($plan) || "$plan" ne 'SKIP')) { + $st_ctx->plan(0) unless defined $plan; + $st_ctx->diag('No tests run!'); + } -=item B<name> + $child->finalize($st_ctx->trace); - diag $builder->name; + $ctx->release; -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". + die $err unless $ok; -=cut + $? = $child_error if defined $child_error; -sub name { shift->{Name} } + return $st_hub->is_passing; +} -sub DESTROY { +sub name { my $self = shift; - if ( $self->parent and $$ == $self->{Original_Pid} ) { - my $name = $self->name; - $self->diag(<<"FAIL"); -Child ($name) exited without calling finalize() -FAIL - $self->parent->{In_Destroy} = 1; - $self->parent->ok(0, $name); - } + my $ctx = $self->ctx; + release $ctx, $ctx->hub->meta(__PACKAGE__, {})->{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. - -=cut - -our $Level; - sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms) - my($self) = @_; + my ($self, %params) = @_; + + Test2::API::test2_set_is_end(0); # 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; - $self->{Name} = $0; - $self->is_passing(1); - $self->{Ending} = 0; - $self->{Have_Plan} = 0; - $self->{No_Plan} = 0; - $self->{Have_Output_Plan} = 0; - $self->{Done_Testing} = 0; - $self->{Original_Pid} = $$; - $self->{Child_Name} = undef; - $self->{Indent} ||= ''; - - $self->{Curr_Test} = 0; - $self->{Test_Results} = &share( [] ); - - $self->{Exported_To} = undef; - $self->{Expected_Tests} = 0; - - $self->{Skip_All} = 0; - $self->{Use_Nums} = 1; - - $self->{No_Header} = 0; - $self->{No_Ending} = 0; - - $self->{Todo} = undef; - $self->{Todo_Stack} = []; - $self->{Start_Todo} = 0; - $self->{Opened_Testhandles} = 0; + my $ctx = $self->ctx; + unless ($params{singleton}) { + $ctx->hub->reset_state(); + $ctx->hub->set_pid($$); + $ctx->hub->set_tid(get_tid); + } - $self->_share_keys; - $self->_dup_stdhandles; + my $meta = $ctx->hub->meta(__PACKAGE__, {}); + %$meta = ( + Name => $0, + Ending => 0, + Done_Testing => undef, + Skip_All => 0, + Test_Results => [], + ); - return; -} + $self->{Exported_To} = undef; + $self->{Orig_Handles} ||= do { + my $format = $ctx->hub->format; + my $out; + if ($format && $format->isa('Test2::Formatter::TAP')) { + $out = $format->handles; + } + $out ? [@$out] : []; + }; -# Shared scalar values are lost when a hash is copied, so we have -# a separate method to restore them. -# Shared references are retained across copies. -sub _share_keys { - my $self = shift; + $self->use_numbers(1); + $self->no_header(0); + $self->no_ending(0); + $self->reset_outputs; - share( $self->{Curr_Test} ); + $ctx->release; return; } -=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. - -If a child calls "skip_all" in the plan, a C<Test::Builder::Exception> is -thrown. Trap this error, call C<finalize()> and don't run any more tests on -the child. - - my $child = $Test->child('some child'); - eval { $child->plan( $condition ? ( skip_all => $reason ) : ( tests => 3 ) ) }; - if ( eval { $@->isa('Test::Builder::Exception') } ) { - $child->finalize; - return; - } - # run your tests - -=cut - my %plan_cmds = ( - no_plan => \&no_plan, - skip_all => \&skip_all, - tests => \&_plan_tests, + no_plan => \&no_plan, + skip_all => \&skip_all, + tests => \&_plan_tests, ); sub plan { @@ -530,9 +423,12 @@ sub plan { return unless $cmd; - local $Level = $Level + 1; + my $ctx = $self->ctx; + my $hub = $ctx->hub; - $self->croak("You tried to plan twice") if $self->{Have_Plan}; + $ctx->throw("You tried to plan twice") if $hub->plan; + + local $Level = $Level + 1; if( my $method = $plan_cmds{$cmd} ) { local $Level = $Level + 1; @@ -540,241 +436,156 @@ sub plan { } else { my @args = grep { defined } ( $cmd, $arg ); - $self->croak("plan() doesn't understand @args"); + $ctx->throw("plan() doesn't understand @args"); } - return 1; + release $ctx, 1; } sub _plan_tests { my($self, $arg) = @_; + my $ctx = $self->ctx; + if($arg) { local $Level = $Level + 1; - return $self->expected_tests($arg); + $self->expected_tests($arg); } elsif( !defined $arg ) { - $self->croak("Got an undefined number of tests"); + $ctx->throw("Got an undefined number of tests"); } else { - $self->croak("You said to run 0 tests"); + $ctx->throw("You said to run 0 tests"); } - return; + $ctx->release; } -=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. - -=cut sub expected_tests { my $self = shift; my($max) = @_; + my $ctx = $self->ctx; + if(@_) { $self->croak("Number of tests must be a positive integer. You gave it '$max'") unless $max =~ /^\+?\d+$/; - $self->{Expected_Tests} = $max; - $self->{Have_Plan} = 1; - - $self->_output_plan($max) unless $self->no_header; + $ctx->plan($max); } - return $self->{Expected_Tests}; -} -=item B<no_plan> + my $hub = $ctx->hub; - $Test->no_plan; + $ctx->release; -Declares that this test will run an indeterminate number of tests. + my $plan = $hub->plan; + return 0 unless $plan; + return 0 if $plan =~ m/\D/; + return $plan; +} -=cut sub no_plan { my($self, $arg) = @_; - $self->carp("no_plan takes no arguments") if $arg; - - $self->{No_Plan} = 1; - $self->{Have_Plan} = 1; + my $ctx = $self->ctx; - return 1; -} - -=begin private - -=item B<_output_plan> - - $tb->_output_plan($max); - $tb->_output_plan($max, $directive); - $tb->_output_plan($max, $directive => $reason); - -Handles displaying the test plan. - -If a C<$directive> and/or C<$reason> are given they will be output with the -plan. So here's what skipping all tests looks like: - - $tb->_output_plan(0, "SKIP", "Because I said so"); - -It sets C<< $tb->{Have_Output_Plan} >> and will croak if the plan was already -output. - -=end private - -=cut - -sub _output_plan { - my($self, $max, $directive, $reason) = @_; - - $self->carp("The plan was already output") if $self->{Have_Output_Plan}; - - my $plan = "1..$max"; - $plan .= " # $directive" if defined $directive; - $plan .= " $reason" if defined $reason; + 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; + } - $self->_print("$plan\n"); + $ctx->alert("no_plan takes no arguments") if $arg; - $self->{Have_Output_Plan} = 1; + $ctx->hub->plan('NO PLAN'); - return; + release $ctx, 1; } -=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. - -$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. - -If C<done_testing()> is called twice, the second call will issue a -failing test. - -If C<$num_tests> is omitted, the number of tests run will be used, like -no_plan. - -C<done_testing()> is, in effect, used when you'd want to use C<no_plan>, but -safer. You'd use it like so: +sub done_testing { + my($self, $num_tests) = @_; - $Test->ok($a == $b); - $Test->done_testing(); + my $ctx = $self->ctx; -Or to plan a variable number of tests: + my $meta = $ctx->hub->meta(__PACKAGE__, {}); - for my $test (@tests) { - $Test->ok($test); + 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; } - $Test->done_testing(scalar @tests); - -=cut + $meta->{Done_Testing} = [$ctx->trace->call]; -sub done_testing { - my($self, $num_tests) = @_; + my $plan = $ctx->hub->plan; + my $count = $ctx->hub->count; - # If done_testing() specified the number of tests, shut off no_plan. + # If done_testing() specified the number of tests, shut off no_plan if( defined $num_tests ) { - $self->{No_Plan} = 0; + $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 { $num_tests = $self->current_test; } - if( $self->{Done_Testing} ) { - my($file, $line) = @{$self->{Done_Testing}}[1,2]; - $self->ok(0, "done_testing() was already called at $file line $line"); - return; - } - - $self->{Done_Testing} = [caller]; - if( $self->expected_tests && $num_tests != $self->expected_tests ) { $self->ok(0, "planned to run @{[ $self->expected_tests ]} ". "but done_testing() expects $num_tests"); } - else { - $self->{Expected_Tests} = $num_tests; - } - - $self->_output_plan($num_tests) unless $self->{Have_Output_Plan}; - $self->{Have_Plan} = 1; + $ctx->plan($num_tests) if $ctx->hub->plan && $ctx->hub->plan eq 'NO PLAN'; - # The wrong number of tests were run - $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test}; + $ctx->hub->finalize($ctx->trace, 1); - # No tests were run - $self->is_passing(0) if $self->{Curr_Test} == 0; - - return 1; + release $ctx, 1; } -=item B<has_plan> - - $plan = $Test->has_plan - -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). - -=cut - sub has_plan { my $self = shift; - return( $self->{Expected_Tests} ) if $self->{Expected_Tests}; - return('no_plan') if $self->{No_Plan}; + my $ctx = $self->ctx; + my $plan = $ctx->hub->plan; + $ctx->release; + + return( $plan ) if $plan && $plan !~ m/\D/; + return('no_plan') if $plan && $plan eq 'NO PLAN'; return(undef); } -=item B<skip_all> - - $Test->skip_all; - $Test->skip_all($reason); - -Skips all the tests, using the given C<$reason>. Exits immediately with 0. - -=cut sub skip_all { my( $self, $reason ) = @_; - $self->{Skip_All} = $self->parent ? $reason : 1; - - $self->_output_plan(0, "SKIP", $reason) unless $self->no_header; - if ( $self->parent ) { - die bless {} => 'Test::Builder::Exception'; - } - exit(0); -} - -=item B<exported_to> + my $ctx = $self->ctx; - my $pack = $Test->exported_to; - $Test->exported_to($pack); + $ctx->hub->meta(__PACKAGE__, {})->{Skip_All} = $reason || 1; -Tells Test::Builder what package you exported your functions to. + # 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}; + } -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. + $ctx->plan(0, SKIP => $reason); +} -=cut sub exported_to { my( $self, $pack ) = @_; @@ -785,171 +596,124 @@ sub exported_to { return $self->{Exported_To}; } -=back - -=head2 Running tests - -These actually run the tests, analogous to the functions in Test::More. - -They all return true if the test passed, false if the test failed. - -C<$name> is always optional. - -=over 4 - -=item B<ok> - - $Test->ok($test, $name); - -Your basic test. Pass if C<$test> is true, fail if $test is false. Just -like Test::Simple's C<ok()>. - -=cut sub ok { my( $self, $test, $name ) = @_; - if ( $self->{Child_Name} and not $self->{In_Destroy} ) { - $name = 'unnamed test' unless defined $name; - $self->is_passing(0); - $self->croak("Cannot run test ($name) with active children"); - } + 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; - lock $self->{Curr_Test}; - $self->{Curr_Test}++; - # In case $name is a string overloaded object, force it to stringify. - $self->_unoverload_str( \$name ); + no warnings qw/uninitialized numeric/; + $name = "$name" if defined $name; - $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/; + # 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 - - # Capture the value of $TODO for the rest of this ok() call - # so it can more easily be found by other routines. - my $todo = $self->todo(); - my $in_todo = $self->in_todo; - local $self->{Todo} = $todo if $in_todo; + 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 : ''), + }; - $self->_unoverload_str( \$todo ); + $hub->{_meta}->{+__PACKAGE__}->{Test_Results}[ $hub->{count} ] = $result; - my $out; - my $result = &share( {} ); + my $orig_name = $name; - unless($test) { - $out .= "not "; - @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 ); - } - else { - @$result{ 'ok', 'actual_ok' } = ( 1, $test ); + my @attrs; + my $subevents = delete $self->{subevents}; + my $subtest_id = delete $self->{subtest_id}; + 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, buffered => $subtest_buffered); } - $out .= "ok"; - $out .= " $self->{Curr_Test}" if $self->use_numbers; + my $e = bless { + trace => bless( {%$trace}, 'Test2::Util::Trace'), + pass => $test, + name => $name, + _meta => {'Test::Builder' => $result}, + effective_pass => $test, + @attrs, + }, $epkg; + $hub->send($e); - if( defined $name ) { - $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. - $out .= " - $name"; - $result->{name} = $name; - } - else { - $result->{name} = ''; - } + $self->_ok_debug($trace, $orig_name) unless($test); - if( $self->in_todo ) { - $out .= " # TODO $todo"; - $result->{reason} = $todo; - $result->{type} = 'todo'; - } - else { - $result->{reason} = ''; - $result->{type} = ''; - } - - $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result; - $out .= "\n"; - - $self->_print($out); + $ctx->release; + return $test; +} - unless($test) { - my $msg = $self->in_todo ? "Failed (TODO)" : "Failed"; - $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE}; +sub _ok_debug { + my $self = shift; + my ($trace, $orig_name) = @_; - my( undef, $file, $line ) = $self->caller; - if( defined $name ) { - $self->diag(qq[ $msg test '$name'\n]); - $self->diag(qq[ at $file line $line.\n]); - } - else { - $self->diag(qq[ $msg test at $file line $line.\n]); - } - } + my $is_todo = defined($self->todo); - $self->is_passing(0) unless $test || $self->in_todo; + my $msg = $is_todo ? "Failed (TODO)" : "Failed"; - # Check that we haven't violated the plan - $self->_check_is_passing_plan(); + my $dfh = $self->_diag_fh; + print $dfh "\n" if $ENV{HARNESS_ACTIVE} && $dfh; - return $test ? 1 : 0; + my (undef, $file, $line) = $trace->call; + if (defined $orig_name) { + $self->diag(qq[ $msg test '$orig_name'\n]); + $self->diag(qq[ at $file line $line.\n]); + } + else { + $self->diag(qq[ $msg test at $file line $line.\n]); + } } - -# Check that we haven't yet violated the plan and set -# is_passing() accordingly -sub _check_is_passing_plan { +sub _diag_fh { my $self = shift; - - my $plan = $self->has_plan; - return unless defined $plan; # no plan yet defined - return unless $plan !~ /\D/; # no numeric plan - $self->is_passing(0) if $plan < $self->{Curr_Test}; + local $Level = $Level + 1; + return $self->in_todo ? $self->todo_output : $self->failure_output; } - sub _unoverload { - my $self = shift; - my $type = shift; - - $self->_try(sub { require overload; }, die_on_fail => 1); + my ($self, $type, $thing) = @_; - foreach my $thing (@_) { - if( $self->_is_object($$thing) ) { - if( my $string_meth = overload::Method( $$thing, $type ) ) { - $$thing = $$thing->$string_meth(); - } - } + return unless ref $$thing; + return unless blessed($$thing) || scalar $self->_try(sub{ $$thing->isa('UNIVERSAL') }); + { + local ($!, $@); + require overload; } - - return; -} - -sub _is_object { - my( $self, $thing ) = @_; - - return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0; + my $string_meth = overload::Method( $$thing, $type ) || return; + $$thing = $$thing->$string_meth(); } sub _unoverload_str { my $self = shift; - return $self->_unoverload( q[""], @_ ); + $self->_unoverload( q[""], $_ ) for @_; } sub _unoverload_num { my $self = shift; - $self->_unoverload( '0+', @_ ); + $self->_unoverload( '0+', $_ ) for @_; for my $val (@_) { next unless $self->_is_dualvar($$val); $$val = $$val + 0; } - - return; } # This is a hack to detect a dualvar such as $! @@ -964,28 +728,12 @@ sub _is_dualvar { return ($numval != 0 and $numval ne $val ? 1 : 0); } -=item B<is_eq> - - $Test->is_eq($got, $expected, $name); - -Like Test::More's C<is()>. Checks if C<$got eq $expected>. This is the -string version. - -C<undef> only ever matches another C<undef>. - -=item B<is_num> - - $Test->is_num($got, $expected, $name); - -Like Test::More's C<is()>. Checks if C<$got == $expected>. This is the -numeric version. - -C<undef> only ever matches another C<undef>. - -=cut sub is_eq { my( $self, $got, $expect, $name ) = @_; + + my $ctx = $self->ctx; + local $Level = $Level + 1; if( !defined $got || !defined $expect ) { @@ -994,14 +742,17 @@ sub is_eq { $self->ok( $test, $name ); $self->_is_diag( $got, 'eq', $expect ) unless $test; + $ctx->release; return $test; } - return $self->cmp_ok( $got, 'eq', $expect, $name ); + release $ctx, $self->cmp_ok( $got, 'eq', $expect, $name ); } + sub is_num { my( $self, $got, $expect, $name ) = @_; + my $ctx = $self->ctx; local $Level = $Level + 1; if( !defined $got || !defined $expect ) { @@ -1010,12 +761,14 @@ sub is_num { $self->ok( $test, $name ); $self->_is_diag( $got, '==', $expect ) unless $test; + $ctx->release; return $test; } - return $self->cmp_ok( $got, '==', $expect, $name ); + release $ctx, $self->cmp_ok( $got, '==', $expect, $name ); } + sub _diag_fmt { my( $self, $type, $val ) = @_; @@ -1036,6 +789,7 @@ sub _diag_fmt { return; } + sub _is_diag { my( $self, $got, $type, $expect ) = @_; @@ -1061,24 +815,10 @@ sub _isnt_diag { DIAGNOSTIC } -=item B<isnt_eq> - - $Test->isnt_eq($got, $dont_expect, $name); - -Like L<Test::More>'s C<isnt()>. Checks if C<$got ne $dont_expect>. This is -the string version. - -=item B<isnt_num> - - $Test->isnt_num($got, $dont_expect, $name); - -Like L<Test::More>'s C<isnt()>. Checks if C<$got ne $dont_expect>. This is -the numeric version. - -=cut sub isnt_eq { my( $self, $got, $dont_expect, $name ) = @_; + my $ctx = $self->ctx; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { @@ -1087,14 +827,16 @@ sub isnt_eq { $self->ok( $test, $name ); $self->_isnt_diag( $got, 'ne' ) unless $test; + $ctx->release; return $test; } - return $self->cmp_ok( $got, 'ne', $dont_expect, $name ); + 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 ) { @@ -1103,52 +845,32 @@ sub isnt_num { $self->ok( $test, $name ); $self->_isnt_diag( $got, '!=' ) unless $test; + $ctx->release; return $test; } - return $self->cmp_ok( $got, '!=', $dont_expect, $name ); + release $ctx, $self->cmp_ok( $got, '!=', $dont_expect, $name ); } -=item B<like> - - $Test->like($thing, qr/$regex/, $name); - $Test->like($thing, '/$regex/', $name); - -Like L<Test::More>'s C<like()>. Checks if $thing matches the given C<$regex>. - -=item B<unlike> - - $Test->unlike($thing, qr/$regex/, $name); - $Test->unlike($thing, '/$regex/', $name); - -Like L<Test::More>'s C<unlike()>. Checks if $thing B<does not match> the -given C<$regex>. - -=cut sub like { my( $self, $thing, $regex, $name ) = @_; + my $ctx = $self->ctx; local $Level = $Level + 1; - return $self->_regex_ok( $thing, $regex, '=~', $name ); + + release $ctx, $self->_regex_ok( $thing, $regex, '=~', $name ); } sub unlike { my( $self, $thing, $regex, $name ) = @_; + my $ctx = $self->ctx; local $Level = $Level + 1; - return $self->_regex_ok( $thing, $regex, '!~', $name ); -} - -=item B<cmp_ok> - - $Test->cmp_ok($thing, $type, $that, $name); - -Works just like L<Test::More>'s C<cmp_ok()>. - $Test->cmp_ok($big_num, '!=', $other_big_num); + release $ctx, $self->_regex_ok( $thing, $regex, '!~', $name ); +} -=cut my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" ); @@ -1157,9 +879,10 @@ 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}) { - $self->croak("$type is not a valid comparison operator in cmp_ok()"); + $ctx->throw("$type is not a valid comparison operator in cmp_ok()"); } my ($test, $succ); @@ -1169,7 +892,7 @@ sub cmp_ok { local( $@, $!, $SIG{__DIE__} ); # isolate eval - my($pack, $file, $line) = $self->caller(); + my($pack, $file, $line) = $ctx->trace->call(); # This is so that warnings come out at the caller's level $succ = eval qq[ @@ -1203,13 +926,26 @@ END $self->_is_diag( $got, $type, $expect ); } elsif( $type =~ /^(ne|!=)$/ ) { - $self->_isnt_diag( $got, $type ); + 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 $ok; + return release $ctx, $ok; } sub _cmp_diag { @@ -1237,182 +973,71 @@ sub _caller_context { return $code; } -=back - - -=head2 Other Testing Methods - -These are methods which are used in the course of writing a test but are not themselves tests. - -=over 4 - -=item B<BAIL_OUT> - - $Test->BAIL_OUT($reason); - -Indicates to the L<Test::Harness> that things are going so badly all -testing should terminate. This includes running any additional test -scripts. - -It will exit with 255. - -=cut sub BAIL_OUT { my( $self, $reason ) = @_; - $self->{Bailed_Out} = 1; + my $ctx = $self->ctx; - if ($self->parent) { - $self->{Bailed_Out_Reason} = $reason; - $self->no_ending(1); - die bless {} => 'Test::Builder::Exception'; - } + $self->{Bailed_Out} = 1; - $self->_print("Bail out! $reason"); - exit 255; + $ctx->bail($reason); } -=for deprecated -BAIL_OUT() used to be BAILOUT() - -=cut { no warnings 'once'; *BAILOUT = \&BAIL_OUT; } -=item B<skip> - - $Test->skip; - $Test->skip($why); - -Skips the current test, reporting C<$why>. - -=cut - sub skip { my( $self, $why, $name ) = @_; $why ||= ''; $name = '' unless defined $name; $self->_unoverload_str( \$why ); - lock( $self->{Curr_Test} ); - $self->{Curr_Test}++; + my $ctx = $self->ctx; - $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share( - { - 'ok' => 1, - actual_ok => 1, - name => $name, - type => 'skip', - reason => $why, - } - ); + $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = { + 'ok' => 1, + actual_ok => 1, + name => $name, + type => 'skip', + reason => $why, + }; - my $out = "ok"; - $out .= " $self->{Curr_Test}" if $self->use_numbers; - $out .= " # skip"; - $out .= " $why" if length $why; - $out .= "\n"; + $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. + $name =~ s{\n}{\n# }sg; + $why =~ s{\n}{\n# }sg; - $self->_print($out); + my $tctx = $ctx->snapshot; + $tctx->skip('', $why); - return 1; + return release $ctx, 1; } -=item B<todo_skip> - - $Test->todo_skip; - $Test->todo_skip($why); - -Like C<skip()>, only it will declare the test as failing and TODO. Similar -to - - print "not ok $tnum # TODO $why\n"; - -=cut sub todo_skip { my( $self, $why ) = @_; $why ||= ''; - lock( $self->{Curr_Test} ); - $self->{Curr_Test}++; + my $ctx = $self->ctx; - $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share( - { - 'ok' => 1, - actual_ok => 0, - name => '', - type => 'todo_skip', - reason => $why, - } - ); - - my $out = "not ok"; - $out .= " $self->{Curr_Test}" if $self->use_numbers; - $out .= " # TODO & SKIP $why\n"; + $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = { + 'ok' => 1, + actual_ok => 0, + name => '', + type => 'todo_skip', + reason => $why, + }; - $self->_print($out); + $why =~ s{\n}{\n# }sg; + my $tctx = $ctx->snapshot; + $tctx->send_event( 'Skip', todo => $why, todo_diag => 1, reason => $why, pass => 0); - return 1; + return release $ctx, 1; } -=begin _unimplemented - -=item B<skip_rest> - - $Test->skip_rest; - $Test->skip_rest($reason); - -Like C<skip()>, only it skips all the rest of the tests you plan to run -and terminates the test. - -If you're running under C<no_plan>, it skips once and terminates the -test. - -=end _unimplemented - -=back - - -=head2 Test building utility methods - -These methods are useful when writing your own test methods. - -=over 4 - -=item B<maybe_regex> - - $Test->maybe_regex(qr/$regex/); - $Test->maybe_regex('/$regex/'); - -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. - -Convenience method for building testing functions that take regular -expressions as arguments. - -Takes a quoted regular expression produced by C<qr//>, or a string -representing a regular expression. - -Returns a Perl value which may be used instead of the corresponding -regular expression, or C<undef> if its argument is not recognised. - -For example, a version of C<like()>, sans the useful diagnostic messages, -could be written as: - - 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); - } - -=cut sub maybe_regex { my( $self, $regex ) = @_; @@ -1494,26 +1119,415 @@ DIAGNOSTIC return $ok; } -# I'm not ready to publish this. It doesn't deal with array return -# values from the code or context. -=begin private +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 ) = @_; -=item B<_try> + if( defined $level ) { + $Level = $level; + } + return $Level; +} - my $return_from_code = $Test->try(sub { code }); - my($return_from_code, $error) = $Test->try(sub { code }); -Works like eval BLOCK except it ensures it has no effect on the rest -of the test (ie. C<$@> is not set) nor is effected by outside -interference (ie. C<$SIG{__DIE__}>) and works around some quirks in older -Perls. +sub use_numbers { + my( $self, $use_nums ) = @_; -C<$error> is what would normally be in C<$@>. + 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; + } -It is suggested you use this in place of eval BLOCK. + $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 $ctx = $self->ctx; + $ctx->diag(join '' => map {defined($_) ? $_ : 'undef'} @_); + $ctx->release; + return 0; +} + + +sub note { + my $self = shift; + return unless @_; + + my $ctx = $self->ctx; + $ctx->note(join '' => map {defined($_) ? $_ : 'undef'} @_); + $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); + + # 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; + + my $ctx = $self->ctx; + my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}; + $ctx->release; + return map { $_->{'ok'} } @$data; +} + + +sub details { + my $self = shift; + 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; +} -=cut sub _try { my( $self, $code, %opts ) = @_; @@ -1533,7 +1547,513 @@ sub _try { return wantarray ? ( $return, $error ) : $return; } -=end private +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(); + my $ipc = Test2::IPC::apply_ipc($self->{Stack}); + $ipc->set_no_fatal(1); + Test2::API::test2_no_wait(1); + Test2::API::test2_ipc_enable_shm(); +} + +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. + +$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. + +If C<done_testing()> is called twice, the second call will issue a +failing test. + +If C<$num_tests> is omitted, the number of tests run will be used, like +no_plan. + +C<done_testing()> is, in effect, used when you'd want to use C<no_plan>, but +safer. You'd use it like so: + + $Test->ok($a == $b); + $Test->done_testing(); + +Or to plan a variable number of tests: + + for my $test (@tests) { + $Test->ok($test); + } + $Test->done_testing(scalar @tests); + + +=item B<has_plan> + + $plan = $Test->has_plan + +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). + +=item B<skip_all> + + $Test->skip_all; + $Test->skip_all($reason); + +Skips all the tests, using the given C<$reason>. Exits immediately with 0. + +=item B<exported_to> + + my $pack = $Test->exported_to; + $Test->exported_to($pack); + +Tells Test::Builder what package you exported your functions to. + +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. + +=back + +=head2 Running tests + +These actually run the tests, analogous to the functions in Test::More. + +They all return true if the test passed, false if the test failed. + +C<$name> is always optional. + +=over 4 + +=item B<ok> + + $Test->ok($test, $name); + +Your basic test. Pass if C<$test> is true, fail if $test is false. Just +like Test::Simple's C<ok()>. + +=item B<is_eq> + + $Test->is_eq($got, $expected, $name); + +Like Test::More's C<is()>. Checks if C<$got eq $expected>. This is the +string version. + +C<undef> only ever matches another C<undef>. + +=item B<is_num> + + $Test->is_num($got, $expected, $name); + +Like Test::More's C<is()>. Checks if C<$got == $expected>. This is the +numeric version. + +C<undef> only ever matches another C<undef>. + +=item B<isnt_eq> + + $Test->isnt_eq($got, $dont_expect, $name); + +Like L<Test::More>'s C<isnt()>. Checks if C<$got ne $dont_expect>. This is +the string version. + +=item B<isnt_num> + + $Test->isnt_num($got, $dont_expect, $name); + +Like L<Test::More>'s C<isnt()>. Checks if C<$got ne $dont_expect>. This is +the numeric version. + +=item B<like> + + $Test->like($thing, qr/$regex/, $name); + $Test->like($thing, '/$regex/', $name); + +Like L<Test::More>'s C<like()>. Checks if $thing matches the given C<$regex>. + +=item B<unlike> + + $Test->unlike($thing, qr/$regex/, $name); + $Test->unlike($thing, '/$regex/', $name); + +Like L<Test::More>'s C<unlike()>. Checks if $thing B<does not match> the +given C<$regex>. + +=item B<cmp_ok> + + $Test->cmp_ok($thing, $type, $that, $name); + +Works just like L<Test::More>'s C<cmp_ok()>. + + $Test->cmp_ok($big_num, '!=', $other_big_num); + +=back + +=head2 Other Testing Methods + +These are methods which are used in the course of writing a test but are not themselves tests. + +=over 4 + +=item B<BAIL_OUT> + + $Test->BAIL_OUT($reason); + +Indicates to the L<Test::Harness> that things are going so badly all +testing should terminate. This includes running any additional test +scripts. + +It will exit with 255. + +=for deprecated +BAIL_OUT() used to be BAILOUT() + +=item B<skip> + + $Test->skip; + $Test->skip($why); + +Skips the current test, reporting C<$why>. + +=item B<todo_skip> + + $Test->todo_skip; + $Test->todo_skip($why); + +Like C<skip()>, only it will declare the test as failing and TODO. Similar +to + + print "not ok $tnum # TODO $why\n"; + +=begin _unimplemented + +=item B<skip_rest> + + $Test->skip_rest; + $Test->skip_rest($reason); + +Like C<skip()>, only it skips all the rest of the tests you plan to run +and terminates the test. + +If you're running under C<no_plan>, it skips once and terminates the +test. + +=end _unimplemented + +=back + + +=head2 Test building utility methods + +These methods are useful when writing your own test methods. + +=over 4 + +=item B<maybe_regex> + + $Test->maybe_regex(qr/$regex/); + $Test->maybe_regex('/$regex/'); + +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. + +Convenience method for building testing functions that take regular +expressions as arguments. + +Takes a quoted regular expression produced by C<qr//>, or a string +representing a regular expression. + +Returns a Perl value which may be used instead of the corresponding +regular expression, or C<undef> if its argument is not recognized. + +For example, a version of C<like()>, sans the useful diagnostic messages, +could be written as: + + 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); + } =item B<is_fh> @@ -1544,17 +2064,6 @@ Determines if the given C<$thing> can be used as a filehandle. =cut -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') }; -} =back @@ -1585,17 +2094,6 @@ localized: To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant. -=cut - -sub level { - my( $self, $level ) = @_; - - if( defined $level ) { - $Level = $level; - } - return $Level; -} - =item B<use_numbers> $Test->use_numbers($on_or_off); @@ -1617,17 +2115,6 @@ when threads or forking is involved. Defaults to on. -=cut - -sub use_numbers { - my( $self, $use_nums ) = @_; - - if( defined $use_nums ) { - $self->{Use_Nums} = $use_nums; - } - return $self->{Use_Nums}; -} - =item B<no_diag> $Test->no_diag($no_diag); @@ -1650,24 +2137,6 @@ If this is true, none of that will be done. If set to true, no "1..N" header will be printed. -=cut - -foreach my $attribute (qw(No_Header No_Ending No_Diag)) { - my $method = lc $attribute; - - my $code = sub { - my( $self, $no ) = @_; - - if( defined $no ) { - $self->{$attribute} = $no; - } - return $self->{$attribute}; - }; - - no strict 'refs'; ## no critic - *{ __PACKAGE__ . '::' . $method } = $code; -} - =back =head2 Output @@ -1703,14 +2172,6 @@ a failing test (C<ok() || diag()>) it "passes through" the failure. =for blame transfer Mark Fowler <mark@twoshortplanks.com> -=cut - -sub diag { - my $self = shift; - - $self->_print_comment( $self->_diag_fh, @_ ); -} - =item B<note> $Test->note(@msgs); @@ -1718,43 +2179,6 @@ sub diag { 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. -=cut - -sub note { - my $self = shift; - - $self->_print_comment( $self->output, @_ ); -} - -sub _diag_fh { - my $self = shift; - - local $Level = $Level + 1; - return $self->in_todo ? $self->todo_output : $self->failure_output; -} - -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 $Level = $Level + 1; - $self->_print_to_fh( $fh, $msg ); - - return 0; -} - =item B<explain> my @dump = $Test->explain(@msgs); @@ -1768,64 +2192,6 @@ or is_deeply($have, $want) || note explain $have; -=cut - -sub explain { - my $self = shift; - - return map { - ref $_ - ? do { - $self->_try(sub { require Data::Dumper }, die_on_fail => 1); - - my $dumper = Data::Dumper->new( [$_] ); - $dumper->Indent(1)->Terse(1); - $dumper->Sortkeys(1) if $dumper->can("Sortkeys"); - $dumper->Dump; - } - : $_ - } @_; -} - -=begin _private - -=item B<_print> - - $Test->_print(@msgs); - -Prints to the C<output()> filehandle. - -=end _private - -=cut - -sub _print { - my $self = shift; - return $self->_print_to_fh( $self->output, @_ ); -} - -sub _print_to_fh { - my( $self, $fh, @msgs ) = @_; - - # Prevent printing headers when only compiling. Mostly for when - # tests are deparsed with B::Deparse - return if $^C; - - my $msg = join '', @msgs; - my $indent = $self->_indent; - - local( $\, $", $, ) = ( undef, ' ', '' ); - - # Escape each line after the first with a # so we don't - # confuse Test::Harness. - $msg =~ s{\n(?!\z)}{\n$indent# }sg; - - # Stick a newline on the end if it needs it. - $msg .= "\n" unless $msg =~ /\n\z/; - - return print $fh $indent, $msg; -} - =item B<output> =item B<failure_output> @@ -1857,151 +2223,12 @@ user. Defaults to STDOUT. -=cut - -sub output { - my( $self, $fh ) = @_; - - if( defined $fh ) { - $self->{Out_FH} = $self->_new_fh($fh); - } - return $self->{Out_FH}; -} - -sub failure_output { - my( $self, $fh ) = @_; - - if( defined $fh ) { - $self->{Fail_FH} = $self->_new_fh($fh); - } - return $self->{Fail_FH}; -} - -sub todo_output { - my( $self, $fh ) = @_; - - if( defined $fh ) { - $self->{Todo_FH} = $self->_new_fh($fh); - } - return $self->{Todo_FH}; -} - -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; -} - -my( $Testout, $Testerr ); - -sub _dup_stdhandles { - my $self = shift; - - $self->_open_testhandles; - - # Set everything to unbuffered else plain prints to STDOUT will - # come out in the wrong order from our own prints. - _autoflush($Testout); - _autoflush( \*STDOUT ); - _autoflush($Testerr); - _autoflush( \*STDERR ); - - $self->reset_outputs; - - return; -} - -sub _open_testhandles { - my $self = shift; - - return if $self->{Opened_Testhandles}; - - # We dup STDOUT and STDERR so people can change them in their - # test suites while still getting normal test output. - open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!"; - open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!"; - - $self->_copy_io_layers( \*STDOUT, $Testout ); - $self->_copy_io_layers( \*STDERR, $Testerr ); - - $self->{Opened_Testhandles} = 1; - - return; -} - -sub _copy_io_layers { - my( $self, $src, $dst ) = @_; - - $self->_try( - sub { - require PerlIO; - my @src_layers = PerlIO::get_layers($src); - - _apply_layers($dst, @src_layers) if @src_layers; - } - ); - - return; -} - -sub _apply_layers { - my ($fh, @layers) = @_; - my %seen; - my @unique = grep { $_ ne 'unix' and !$seen{$_}++ } @layers; - binmode($fh, join(":", "", "raw", @unique)); -} - - =item reset_outputs $tb->reset_outputs; Resets all the output filehandles back to their defaults. -=cut - -sub reset_outputs { - my $self = shift; - - $self->output ($Testout); - $self->failure_output($Testerr); - $self->todo_output ($Testout); - - return; -} - =item carp $tb->carp(@message); @@ -2016,26 +2243,6 @@ point where the original test function was called (C<< $tb->caller >>). Dies with C<@message> but the message will appear to come from the point where the original test function was called (C<< $tb->caller >>). -=cut - -sub _message_at_caller { - my $self = shift; - - local $Level = $Level + 1; - my( $pack, $file, $line ) = $self->caller; - return join( "", @_ ) . " at $file line $line.\n"; -} - -sub carp { - my $self = shift; - return warn $self->_message_at_caller(@_); -} - -sub croak { - my $self = shift; - return die $self->_message_at_caller(@_); -} - =back @@ -2056,38 +2263,6 @@ 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. -=cut - -sub current_test { - my( $self, $num ) = @_; - - lock( $self->{Curr_Test} ); - if( defined $num ) { - $self->{Curr_Test} = $num; - - # If the test counter is being pushed forward fill in the details. - my $test_results = $self->{Test_Results}; - if( $num > @$test_results ) { - my $start = @$test_results ? @$test_results : 0; - for( $start .. $num - 1 ) { - $test_results->[$_] = &share( - { - '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 $self->{Curr_Test}; -} =item B<is_passing> @@ -2104,18 +2279,6 @@ test to it and start passing. Don't think about it too much. -=cut - -sub is_passing { - my $self = shift; - - if( @_ ) { - $self->{Is_Passing} = shift; - } - - return $self->{Is_Passing}; -} - =item B<summary> @@ -2126,13 +2289,6 @@ This is a logical pass/fail, so todos are passes. Of course, test #1 is $tests[0], etc... -=cut - -sub summary { - my($self) = shift; - - return map { $_->{'ok'} } @{ $self->{Test_Results} }; -} =item B<details> @@ -2140,7 +2296,7 @@ sub summary { Like C<summary()>, but with a lot more detail. - $tests[$test_num - 1] = + $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) @@ -2181,12 +2337,6 @@ result in this structure: reason => 'insufficient donuts' }; -=cut - -sub details { - my $self = shift; - return @{ $self->{Test_Results} }; -} =item B<todo> @@ -2210,20 +2360,6 @@ 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. -=cut - -sub todo { - my( $self, $pack ) = @_; - - return $self->{Todo} if defined $self->{Todo}; - - local $Level = $Level + 1; - my $todo = $self->find_TODO($pack); - return $todo if defined $todo; - - return ''; -} - =item B<find_TODO> my $todo_reason = $Test->find_TODO(); @@ -2237,35 +2373,12 @@ old value: my $old_reason = $Test->find_TODO($pack, 1, $new_reason); -=cut - -sub find_TODO { - my( $self, $pack, $set, $new_value ) = @_; - - $pack = $pack || $self->caller(1) || $self->exported_to; - return unless $pack; - - no strict 'refs'; ## no critic - my $old_value = ${ $pack . '::TODO' }; - $set and ${ $pack . '::TODO' } = $new_value; - return $old_value; -} - =item B<in_todo> my $in_todo = $Test->in_todo; Returns true if the test is currently inside a TODO block. -=cut - -sub in_todo { - my $self = shift; - - local $Level = $Level + 1; - return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0; -} - =item B<todo_start> $Test->todo_start(); @@ -2307,20 +2420,6 @@ guaranteed and its use is also discouraged: Pick one style or another of "TODO" to be on the safe side. -=cut - -sub todo_start { - my $self = shift; - my $message = @_ ? shift : ''; - - $self->{Start_Todo}++; - if( $self->in_todo ) { - push @{ $self->{Todo_Stack} } => $self->todo; - } - $self->{Todo} = $message; - - return; -} =item C<todo_end> @@ -2329,27 +2428,6 @@ sub todo_start { Stops running tests as "TODO" tests. This method is fatal if called without a preceding C<todo_start> method call. -=cut - -sub todo_end { - my $self = shift; - - if( !$self->{Start_Todo} ) { - $self->croak('todo_end() called without todo_start()'); - } - - $self->{Start_Todo}--; - - if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) { - $self->{Todo} = pop @{ $self->{Todo_Stack} }; - } - else { - delete $self->{Todo}; - } - - return; -} - =item B<caller> my $package = $Test->caller; @@ -2362,233 +2440,8 @@ C<$height> will be added to the C<level()>. If C<caller()> winds up off the top of the stack it report the highest context. -=cut - -sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms) - my( $self, $height ) = @_; - $height ||= 0; - - my $level = $self->level + $height + 1; - my @caller; - do { - @caller = CORE::caller( $level ); - $level--; - } until @caller; - return wantarray ? @caller : $caller[0]; -} - =back -=cut - -=begin _private - -=over 4 - -=item B<_sanity_check> - - $self->_sanity_check(); - -Runs a bunch of end of test sanity checks to make sure reality came -through ok. If anything is wrong it will die with a fairly friendly -error message. - -=cut - -#'# -sub _sanity_check { - my $self = shift; - - $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' ); - $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} }, - 'Somehow you got a different number of results than tests ran!' ); - - return; -} - -=item B<_whoa> - - $self->_whoa($check, $description); - -A sanity check, similar to C<assert()>. If the C<$check> is true, something -has gone horribly wrong. It will die with the given C<$description> and -a note to contact the author. - -=cut - -sub _whoa { - my( $self, $check, $desc ) = @_; - if($check) { - local $Level = $Level + 1; - $self->croak(<<"WHOA"); -WHOA! $desc -This should never happen! Please contact the author immediately! -WHOA - } - - return; -} - -=item B<_my_exit> - - _my_exit($exit_num); - -Perl seems to have some trouble with exiting inside an C<END> block. -5.6.1 does some odd things. Instead, this function edits C<$?> -directly. It should B<only> be called from inside an C<END> block. -It doesn't actually exit, that's your job. - -=cut - -sub _my_exit { - $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars) - - return 1; -} - -=back - -=end _private - -=cut - -sub _ending { - my $self = shift; - return if $self->no_ending; - return if $self->{Ending}++; - - my $real_exit_code = $?; - - # Don't bother with an ending if this is a forked copy. Only the parent - # should do the ending. - if( $self->{Original_Pid} != $$ ) { - return; - } - - # Ran tests but never declared a plan or hit done_testing - if( !$self->{Have_Plan} and $self->{Curr_Test} ) { - $self->is_passing(0); - $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 $self->{Curr_Test}. -FAIL - $self->is_passing(0); - _my_exit($real_exit_code) && return; - } - - # But if the tests ran, handle exit code. - my $test_results = $self->{Test_Results}; - if(@$test_results) { - my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ]; - if ($num_failed > 0) { - - my $exit_code = $num_failed <= 254 ? $num_failed : 254; - _my_exit($exit_code) && return; - } - } - _my_exit(254) && return; - } - - # Exit if plan() was never called. This is so "require Test::Simple" - # doesn't puke. - if( !$self->{Have_Plan} ) { - return; - } - - # Don't do an ending if we bailed out. - if( $self->{Bailed_Out} ) { - $self->is_passing(0); - return; - } - # Figure out if we passed or failed and print helpful messages. - my $test_results = $self->{Test_Results}; - if(@$test_results) { - # The plan? We have no plan. - if( $self->{No_Plan} ) { - $self->_output_plan($self->{Curr_Test}) unless $self->no_header; - $self->{Expected_Tests} = $self->{Curr_Test}; - } - - # Auto-extended arrays and elements which aren't explicitly - # filled in with a shared reference will puke under 5.8.0 - # ithreads. So we have to fill them in by hand. :( - my $empty_result = &share( {} ); - for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) { - $test_results->[$idx] = $empty_result - unless defined $test_results->[$idx]; - } - - my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ]; - - my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; - - if( $num_extra != 0 ) { - my $s = $self->{Expected_Tests} == 1 ? '' : 's'; - $self->diag(<<"FAIL"); -Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}. -FAIL - $self->is_passing(0); - } - - if($num_failed) { - my $num_tests = $self->{Curr_Test}; - my $s = $num_failed == 1 ? '' : 's'; - - my $qualifier = $num_extra == 0 ? '' : ' run'; - - $self->diag(<<"FAIL"); -Looks like you failed $num_failed test$s of $num_tests$qualifier. -FAIL - $self->is_passing(0); - } - - if($real_exit_code) { - $self->diag(<<"FAIL"); -Looks like your test exited with $real_exit_code just after $self->{Curr_Test}. -FAIL - $self->is_passing(0); - _my_exit($real_exit_code) && return; - } - - my $exit_code; - if($num_failed) { - $exit_code = $num_failed <= 254 ? $num_failed : 254; - } - elsif( $num_extra != 0 ) { - $exit_code = 255; - } - else { - $exit_code = 0; - } - - _my_exit($exit_code) && return; - } - elsif( $self->{Skip_All} ) { - _my_exit(0) && return; - } - elsif($real_exit_code) { - $self->diag(<<"FAIL"); -Looks like your test exited with $real_exit_code before it could output anything. -FAIL - $self->is_passing(0); - _my_exit($real_exit_code) && return; - } - else { - $self->diag("No tests run!\n"); - $self->is_passing(0); - _my_exit(255) && return; - } - - $self->is_passing(0); - $self->_whoa( 1, "We fell off the end of _ending()" ); -} - -END { - $Test->_ending if defined $Test; -} - =head1 EXIT CODES If all your tests passed, Test::Builder will exit with zero (which is @@ -2609,9 +2462,9 @@ If you fail more than 254 tests, it will be reported as 254. =head1 THREADS -In perl 5.8.1 and later, Test::Builder is thread-safe. The test -number is shared amongst all threads. This means if one thread sets -the test number using C<current_test()> they will all be effected. +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. While versions earlier than 5.8.1 had threads they contain too many bugs to support. @@ -2665,8 +2518,3 @@ This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://www.perl.com/perl/misc/Artistic.html> - -=cut - -1; - diff --git a/Master/tlpkg/tlperl/lib/Test/Builder/Formatter.pm b/Master/tlpkg/tlperl/lib/Test/Builder/Formatter.pm new file mode 100755 index 00000000000..96571c6005d --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test/Builder/Formatter.pm @@ -0,0 +1,122 @@ +package Test::Builder::Formatter; +use strict; +use warnings; + +our $VERSION = '1.302073'; + +BEGIN { require Test2::Formatter::TAP; our @ISA = qw(Test2::Formatter::TAP) } + +use Test2::Util::HashBase qw/no_header no_diag/; + +BEGIN { + *OUT_STD = Test2::Formatter::TAP->can('OUT_STD'); + *OUT_ERR = Test2::Formatter::TAP->can('OUT_ERR'); + + my $todo = OUT_ERR() + 1; + *OUT_TODO = sub() { $todo }; +} + +__PACKAGE__->register_event('Test::Builder::TodoDiag', 'event_todo_diag'); + +sub init { + my $self = shift; + $self->SUPER::init(@_); + $self->{+HANDLES}->[OUT_TODO] = $self->{+HANDLES}->[OUT_STD]; +} + +sub event_todo_diag { + my $self = shift; + my @out = $self->event_diag(@_); + $out[0]->[0] = OUT_TODO(); + return @out; +} + +sub event_diag { + my $self = shift; + return if $self->{+NO_DIAG}; + return $self->SUPER::event_diag(@_); +} + +sub event_plan { + my $self = shift; + return if $self->{+NO_HEADER}; + return $self->SUPER::event_plan(@_); +} + +sub event_ok_multiline { + my $self = shift; + my ($out, $space, @extra) = @_; + + return( + [OUT_STD, "$out\n"], + map {[OUT_STD, "# $_\n"]} @extra, + ); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test::Builder::Formatter - Test::Builder subclass of Test2::Formatter::TAP + +=head1 DESCRIPTION + +This is what takes events and turns them into TAP. + +=head1 SYNOPSIS + + use Test::Builder; # Loads Test::Builder::Formatter for you + +=head1 METHODS + +=over 4 + +=item $f->event_todo_diag + +Additional method used to process L<Test::Builder::TodoDiag> events. + +=item $f->event_diag + +=item $f->event_plan + +These override the parent class methods to do nothing if C<no_header> is set. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test/Builder/Module.pm b/Master/tlpkg/tlperl/lib/Test/Builder/Module.pm index 2322d8a9b78..6fbba79fc0f 100644 --- a/Master/tlpkg/tlperl/lib/Test/Builder/Module.pm +++ b/Master/tlpkg/tlperl/lib/Test/Builder/Module.pm @@ -2,13 +2,12 @@ package Test::Builder::Module; use strict; -use Test::Builder 1.00; +use Test::Builder; require Exporter; our @ISA = qw(Exporter); -our $VERSION = '1.001014'; -$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) +our $VERSION = '1.302073'; =head1 NAME @@ -22,7 +21,7 @@ Test::Builder::Module - Base class for test modules my $CLASS = __PACKAGE__; - use base 'Test::Builder::Module'; + use parent 'Test::Builder::Module'; @EXPORT = qw(ok); sub ok ($;$) { @@ -90,7 +89,8 @@ sub import { $test->plan(@_); - $class->export_to_level( 1, $class, @imports ); + local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; + $class->Exporter::import(@imports); } sub _strip_imports { diff --git a/Master/tlpkg/tlperl/lib/Test/Builder/Tester.pm b/Master/tlpkg/tlperl/lib/Test/Builder/Tester.pm index b0554b89aca..647ea2d3710 100644 --- a/Master/tlpkg/tlperl/lib/Test/Builder/Tester.pm +++ b/Master/tlpkg/tlperl/lib/Test/Builder/Tester.pm @@ -1,9 +1,9 @@ package Test::Builder::Tester; use strict; -our $VERSION = "1.28"; +our $VERSION = '1.302073'; -use Test::Builder 0.99; +use Test::Builder; use Symbol; use Carp; @@ -104,16 +104,26 @@ my $original_is_passing; my $original_output_handle; my $original_failure_handle; my $original_todo_handle; +my $original_formatter; my $original_harness_env; # function that starts testing and redirects the filehandles for now sub _start_testing { + # Hack for things that conditioned on Test-Stream being loaded + $INC{'Test/Stream.pm'} ||= 'fake' if $INC{'Test/Moose/More.pm'}; # even if we're running under Test::Harness pretend we're not # for now. This needed so Test::Builder doesn't add extra spaces $original_harness_env = $ENV{HARNESS_ACTIVE} || 0; $ENV{HARNESS_ACTIVE} = 0; + my $hub = $t->{Hub} || Test2::API::test2_stack->top; + $original_formatter = $hub->format; + unless ($original_formatter && $original_formatter->isa('Test::Builder::Formatter')) { + my $fmt = Test::Builder::Formatter->new; + $hub->format($fmt); + } + # remember what the handles were set to $original_output_handle = $t->output(); $original_failure_handle = $t->failure_output(); @@ -304,6 +314,8 @@ will function normally and cause success/errors for L<Test::Harness>. =cut sub test_test { + # END the hack + delete $INC{'Test/Stream.pm'} if $INC{'Test/Stream.pm'} && $INC{'Test/Stream.pm'} eq 'fake'; # decode the arguments as described in the pod my $mess; my %args; @@ -321,6 +333,10 @@ sub test_test { croak "Not testing. You must declare output with a test function first." unless $testing; + + my $hub = $t->{Hub} || Test2::API::test2_stack->top; + $hub->format($original_formatter); + # okay, reconnect the test suite back to the saved handles $t->output($original_output_handle); $t->failure_output($original_failure_handle); @@ -420,17 +436,26 @@ sub color { =head1 BUGS +Test::Builder::Tester does not handle plans well. It has never done anything +special with plans. This means that plans from outside Test::Builder::Tester +will effect Test::Builder::Tester, worse plans when using Test::Builder::Tester +will effect overall testing. At this point there are no plans to fix this bug +as people have come to depend on it, and Test::Builder::Tester is now +discouraged in favor of C<Test2::API::intercept()>. See +L<https://github.com/Test-More/test-more/issues/667> + Calls C<< Test::Builder->no_ending >> turning off the ending tests. This is needed as otherwise it will trip out because we've run more tests than we strictly should have and it'll register any failures we had that we were testing for as real failures. The color function doesn't work unless L<Term::ANSIColor> is -compatible with your terminal. +compatible with your terminal. Additionally, L<Win32::Console::ANSI> +must be installed on windows platforms for color output. Bugs (and requests for new features) can be reported to the author -though the CPAN RT system: -L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Builder-Tester> +though GitHub: +L<https://github.com/Test-More/test-more/issues> =head1 AUTHOR @@ -487,8 +512,9 @@ sub expect { sub _account_for_subtest { my( $self, $check ) = @_; - # Since we ship with Test::Builder, calling a private method is safe...ish. - return ref($check) ? $check : $t->_indent . $check; + my $hub = $t->{Stack}->top; + my $nesting = $hub->isa('Test2::Hub::Subtest') ? $hub->nested : 0; + return ref($check) ? $check : (' ' x $nesting) . $check; } sub _translate_Failed_check { @@ -535,6 +561,8 @@ sub complaint { # get color eval { require Term::ANSIColor }; unless($@) { + eval { require Win32::Console::ANSI } if 'MSWin32' eq $^O; # support color on windows platforms + # colours my $green = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_green"); @@ -563,6 +591,33 @@ sub complaint { } } + my @got = split "\n", $got; + my @wanted = split "\n", $wanted; + + $got = ""; + $wanted = ""; + + while (@got || @wanted) { + my $g = shift @got || ""; + my $w = shift @wanted || ""; + if ($g ne $w) { + if($g =~ s/(\s+)$/ |> /g) { + $g .= ($_ eq ' ' ? '_' : '\t') for split '', $1; + } + if($w =~ s/(\s+)$/ |> /g) { + $w .= ($_ eq ' ' ? '_' : '\t') for split '', $1; + } + $g = "> $g"; + $w = "> $w"; + } + else { + $g = " $g"; + $w = " $w"; + } + $got = $got ? "$got\n$g" : $g; + $wanted = $wanted ? "$wanted\n$w" : $w; + } + return "$type is:\n" . "$got\nnot:\n$wanted\nas expected"; } diff --git a/Master/tlpkg/tlperl/lib/Test/Builder/Tester/Color.pm b/Master/tlpkg/tlperl/lib/Test/Builder/Tester/Color.pm index 9a89310f1f3..939e7f1cd36 100644 --- a/Master/tlpkg/tlperl/lib/Test/Builder/Tester/Color.pm +++ b/Master/tlpkg/tlperl/lib/Test/Builder/Tester/Color.pm @@ -1,7 +1,7 @@ package Test::Builder::Tester::Color; use strict; -our $VERSION = "1.290001"; +our $VERSION = '1.302073'; require Test::Builder::Tester; diff --git a/Master/tlpkg/tlperl/lib/Test/Builder/TodoDiag.pm b/Master/tlpkg/tlperl/lib/Test/Builder/TodoDiag.pm new file mode 100755 index 00000000000..74ae0787b66 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test/Builder/TodoDiag.pm @@ -0,0 +1,61 @@ +package Test::Builder::TodoDiag; +use strict; +use warnings; + +our $VERSION = '1.302073'; + +BEGIN { require Test2::Event::Diag; our @ISA = qw(Test2::Event::Diag) } + +sub diagnostics { 0 } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test::Builder::TodoDiag - Test::Builder subclass of Test2::Event::Diag + +=head1 DESCRIPTION + +This is used to encapsulate diag messages created inside TODO. + +=head1 SYNOPSIS + +You do not need to use this directly. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test/Harness.pm b/Master/tlpkg/tlperl/lib/Test/Harness.pm index fe9d3049f9f..3ec34931cee 100644 --- a/Master/tlpkg/tlperl/lib/Test/Harness.pm +++ b/Master/tlpkg/tlperl/lib/Test/Harness.pm @@ -31,11 +31,11 @@ Test::Harness - Run Perl standard test scripts with statistics =head1 VERSION -Version 3.36 +Version 3.38 =cut -our $VERSION = '3.36_01'; +our $VERSION = '3.38'; # Backwards compatibility for exportable variable names. *verbose = *Verbose; @@ -147,6 +147,7 @@ sub runtests { my $harness = _new_harness(); my $aggregate = TAP::Parser::Aggregator->new(); + local $ENV{PERL_USE_UNSAFE_INC} = 1 if not exists $ENV{PERL_USE_UNSAFE_INC}; _aggregate( $harness, $aggregate, @tests ); $harness->formatter->summary($aggregate); @@ -354,6 +355,7 @@ sub execute_tests { } ); + local $ENV{PERL_USE_UNSAFE_INC} = 1 if not exists $ENV{PERL_USE_UNSAFE_INC}; _aggregate( $harness, $aggregate, @{ $args{tests} } ); $tot{bench} = $aggregate->elapsed; diff --git a/Master/tlpkg/tlperl/lib/Test/More.pm b/Master/tlpkg/tlperl/lib/Test/More.pm index 4bab267fcf6..2863c1bba5b 100644 --- a/Master/tlpkg/tlperl/lib/Test/More.pm +++ b/Master/tlpkg/tlperl/lib/Test/More.pm @@ -17,10 +17,9 @@ sub _carp { return warn @_, " at $file line $line\n"; } -our $VERSION = '1.001014'; -$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) +our $VERSION = '1.302073'; -use Test::Builder::Module 0.99; +use Test::Builder::Module; our @ISA = qw(Test::Builder::Module); our @EXPORT = qw(ok use_ok require_ok is isnt like unlike is_deeply @@ -126,6 +125,8 @@ the end. done_testing( $number_of_tests_run ); +B<NOTE> C<done_testing()> should never be called in an C<END { ... }> block. + Sometimes you really don't know how many tests were run, or it's too difficult to calculate. In which case you can leave off $number_of_tests_run. @@ -176,12 +177,22 @@ sub import_extra { my @other = (); my $idx = 0; + my $import; while( $idx <= $#{$list} ) { my $item = $list->[$idx]; if( defined $item and $item eq 'no_diag' ) { $class->builder->no_diag(1); } + elsif( defined $item and $item eq 'import' ) { + if ($import) { + push @$import, @{$list->[ ++$idx ]}; + } + else { + $import = $list->[ ++$idx ]; + push @other, $item, $import; + } + } else { push @other, $item; } @@ -191,6 +202,18 @@ sub import_extra { @$list = @other; + if ($class eq __PACKAGE__ && (!$import || grep $_ eq '$TODO', @$import)) { + my $to = $class->builder->exported_to; + no strict 'refs'; + *{"$to\::TODO"} = \our $TODO; + if ($import) { + @$import = grep $_ ne '$TODO', @$import; + } + else { + push @$list, import => [grep $_ ne '$TODO', @EXPORT]; + } + } + return; } @@ -211,6 +234,10 @@ conclusion. This is safer than and replaces the "no_plan" plan. +B<Note:> You must never put C<done_testing()> inside an C<END { ... }> block. +The plan is there to ensure your test does not exit before testing has +completed. If you use an END block you completely bypass this protection. + =back =cut @@ -703,7 +730,7 @@ sub new_ok { =item B<subtest> - subtest $name => \&code; + subtest $name => \&code, @args; C<subtest()> runs the &code as its own little test with its own plan and its own result. The main test counts this as a single test using the @@ -762,11 +789,20 @@ subtests are equivalent: done_testing(); }; +Extra arguments given to C<subtest> are passed to the callback. For example: + + sub my_subtest { + my $range = shift; + ... + } + + for my $range (1, 10, 100, 1000) { + subtest "testing range $range", \&my_subtest, $range; + } + =cut sub subtest { - my ($name, $subtests) = @_; - my $tb = Test::More->builder; return $tb->subtest(@_); } @@ -940,7 +976,10 @@ sub use_ok ($;@) { @imports = () unless @imports; my $tb = Test::More->builder; - my( $pack, $filename, $line ) = caller; + my %caller; + @caller{qw/pack file line sub args want eval req strict warn/} = caller(0); + + my ($pack, $filename, $line, $warn) = @caller{qw/pack file line warn/}; $filename =~ y/\n\r/_/; # so it doesn't run off the "#line $line $f" line my $code; @@ -949,7 +988,7 @@ sub use_ok ($;@) { # for it to work with non-Exporter based modules. $code = <<USE; package $pack; - +BEGIN { \${^WARNING_BITS} = \$args[-1] if defined \$args[-1] } #line $line $filename use $module $imports[0]; 1; @@ -958,14 +997,14 @@ USE else { $code = <<USE; package $pack; - +BEGIN { \${^WARNING_BITS} = \$args[-1] if defined \$args[-1] } #line $line $filename use $module \@{\$args[0]}; 1; USE } - my( $eval_result, $eval_error ) = _eval( $code, \@imports ); + my ($eval_result, $eval_error) = _eval($code, \@imports, $warn); my $ok = $tb->ok( $eval_result, "use $module;" ); unless($ok) { @@ -1034,6 +1073,20 @@ improve in the future. L<Test::Differences> and L<Test::Deep> provide more in-depth functionality along these lines. +B<NOTE> is_deeply() has limitations when it comes to comparing strings and +refs: + + my $path = path('.'); + my $hash = {}; + is_deeply( $path, "$path" ); # ok + is_deeply( $hash, "$hash" ); # fail + +This happens because is_deeply will unoverload all arguments unconditionally. +It is probably best not to use is_deeply with overloading. For legacy reasons +this is not likely to ever be fixed. If you would like a much better tool for +this you should see L<Test2::Suite> Specifically L<Test2::Tools::Compare> has +an C<is()> function that works like C<is_deeply> with many improvements. + =cut our( @Data_Stack, %Refs_Seen ); @@ -1134,7 +1187,7 @@ sub _type { return '' if !ref $thing; - for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE)) { + for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE VSTRING)) { return $type if UNIVERSAL::isa( $thing, $type ); } @@ -1293,10 +1346,13 @@ sub skip { my( $why, $how_many ) = @_; my $tb = Test::More->builder; - unless( defined $how_many ) { - # $how_many can only be avoided when no_plan is in use. + # If the plan is set, and is static, then skip needs a count. If the plan + # is 'no_plan' we are fine. As well if plan is undefined then we are + # waiting for done_testing. + unless (defined $how_many) { + my $plan = $tb->has_plan; _carp "skip() needs to know \$how_many tests are in the block" - unless $tb->has_plan eq 'no_plan'; + if $plan && $plan =~ m/^\d+$/; $how_many = 1; } @@ -1903,8 +1959,6 @@ comes from. =head2 BUNDLES -L<Bundle::Test> installs a whole bunch of useful test modules. - L<Test::Most> Most commonly needed test functions and features. =head1 AUTHORS @@ -1925,7 +1979,7 @@ the perl-qa gang. =head1 BUGS -See F<http://rt.cpan.org> to report and view bugs. +See F<https://github.com/Test-More/test-more/issues> to report and view bugs. =head1 SOURCE diff --git a/Master/tlpkg/tlperl/lib/Test/Simple.pm b/Master/tlpkg/tlperl/lib/Test/Simple.pm index 56457b407f8..f148fe62c93 100644 --- a/Master/tlpkg/tlperl/lib/Test/Simple.pm +++ b/Master/tlpkg/tlperl/lib/Test/Simple.pm @@ -4,10 +4,9 @@ use 5.006; use strict; -our $VERSION = '1.001014'; -$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) +our $VERSION = '1.302073'; -use Test::Builder::Module 0.99; +use Test::Builder::Module; our @ISA = qw(Test::Builder::Module); our @EXPORT = qw(ok); diff --git a/Master/tlpkg/tlperl/lib/Test/Tester.pm b/Master/tlpkg/tlperl/lib/Test/Tester.pm index a5f1ccfdbb8..a324a1bf479 100644 --- a/Master/tlpkg/tlperl/lib/Test/Tester.pm +++ b/Master/tlpkg/tlperl/lib/Test/Tester.pm @@ -16,9 +16,10 @@ use Test::Tester::Delegate; require Exporter; -use vars qw( @ISA @EXPORT $VERSION ); +use vars qw( @ISA @EXPORT ); + +our $VERSION = '1.302073'; -$VERSION = "0.114"; @EXPORT = qw( run_tests check_tests check_test cmp_results show_space ); @ISA = qw( Exporter ); @@ -39,10 +40,11 @@ sub show_space my $colour = ''; my $reset = ''; -if (my $want_colour = $ENV{TESTTESTERCOLOUR} || $ENV{TESTTESTERCOLOUR}) +if (my $want_colour = $ENV{TESTTESTERCOLOUR} || $ENV{TESTTESTERCOLOR}) { - if (eval "require Term::ANSIColor") + if (eval { require Term::ANSIColor; 1 }) { + eval { require Win32::Console::ANSI } if 'MSWin32' eq $^O; # support color on windows platforms my ($f, $b) = split(",", $want_colour); $colour = Term::ANSIColor::color($f).Term::ANSIColor::color("on_$b"); $reset = Term::ANSIColor::color("reset"); @@ -446,7 +448,7 @@ diagnostics output B<after> the test result is declared. Note that Test::Builder ensures that any diagnostics end in a \n and it in earlier versions of Test::Tester it was essential that you have -the final \n in your expected diagnostics. From version 0.10 onwards, +the final \n in your expected diagnostics. From version 0.10 onward, Test::Tester will add the \n if you forgot it. It will not add a \n if you are expecting no diagnostics. See below for help tracking down hard to find space and tab related problems. @@ -495,7 +497,7 @@ are scratching your head trying to work out why Test::Tester is saying that your diagnostics are wrong when they look perfectly right then the answer is probably whitespace. From version 0.10 on, Test::Tester surrounds the expected and got diag values with single quotes to make it easier to spot -trailing whitesapce. So in this example +trailing whitespace. So in this example # Got diag (5 bytes): # 'abcd ' @@ -513,7 +515,7 @@ switch Test::Tester into a mode whereby all "tricky" characters are shown as \{xx}. Tricky characters are those with ASCII code less than 33 or higher than 126. This makes the output more difficult to read but much easier to find subtle differences between strings. To turn on this mode either call -show_space() in your test script or set the TESTTESTERSPACE environment +C<show_space()> in your test script or set the C<TESTTESTERSPACE> environment variable to be a true value. The example above would then look like # Got diag (5 bytes): @@ -524,13 +526,13 @@ variable to be a true value. The example above would then look like =head1 COLOUR If you prefer to use colour as a means of finding tricky whitespace -characters then you can set the TESTTESTCOLOUR environment variable to a +characters then you can set the C<TESTTESTCOLOUR> environment variable to a comma separated pair of colours, the first for the foreground, the second for the background. For example "white,red" will print white text on a red background. This requires the Term::ANSIColor module. You can specify any colour that would be acceptable to the Term::ANSIColor::color function. -If you spell colour differently, that's no problem. The TESTTESTERCOLOR +If you spell colour differently, that's no problem. The C<TESTTESTERCOLOR> variable also works (if both are set then the British spelling wins out). =head1 EXPORTED FUNCTIONS diff --git a/Master/tlpkg/tlperl/lib/Test/Tester/Capture.pm b/Master/tlpkg/tlperl/lib/Test/Tester/Capture.pm index 00e12e6458e..d8eb170b6c5 100644 --- a/Master/tlpkg/tlperl/lib/Test/Tester/Capture.pm +++ b/Master/tlpkg/tlperl/lib/Test/Tester/Capture.pm @@ -2,6 +2,9 @@ use strict; package Test::Tester::Capture; +our $VERSION = '1.302073'; + + use Test::Builder; use vars qw( @ISA ); @@ -42,6 +45,8 @@ sub new sub ok { my($self, $test, $name) = @_; + 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; @@ -51,7 +56,7 @@ sub ok { my($pack, $file, $line) = $self->caller; - my $todo = $self->todo($pack); + my $todo = $self->todo(); my $result = {}; share($result); @@ -92,6 +97,8 @@ sub ok { $result->{_level} = $Test::Builder::Level; $result->{_depth} = Test::Tester::find_run_tests(); + $ctx->release; + return $test ? 1 : 0; } @@ -99,6 +106,8 @@ sub skip { my($self, $why) = @_; $why ||= ''; + my $ctx = $self->ctx; + lock($Curr_Test); $Curr_Test++; @@ -116,6 +125,7 @@ sub skip { ); $Test_Results[$Curr_Test-1] = \%result; + $ctx->release; return 1; } @@ -123,6 +133,8 @@ sub todo_skip { my($self, $why) = @_; $why ||= ''; + my $ctx = $self->ctx; + lock($Curr_Test); $Curr_Test++; @@ -141,6 +153,7 @@ sub todo_skip { $Test_Results[$Curr_Test-1] = \%result; + $ctx->release; return 1; } @@ -151,6 +164,8 @@ sub diag { # Prevent printing headers when compiling (i.e. -c) return if $^C; + my $ctx = $self->ctx; + # Escape each line with a #. foreach (@msgs) { $_ = 'undef' unless defined; @@ -162,6 +177,7 @@ sub diag { $result->{diag} .= join("", @msgs); + $ctx->release; return 0; } diff --git a/Master/tlpkg/tlperl/lib/Test/Tester/CaptureRunner.pm b/Master/tlpkg/tlperl/lib/Test/Tester/CaptureRunner.pm index f14a4c145aa..bed18e8c483 100644 --- a/Master/tlpkg/tlperl/lib/Test/Tester/CaptureRunner.pm +++ b/Master/tlpkg/tlperl/lib/Test/Tester/CaptureRunner.pm @@ -3,6 +3,9 @@ use strict; package Test::Tester::CaptureRunner; +our $VERSION = '1.302073'; + + use Test::Tester::Capture; require Exporter; diff --git a/Master/tlpkg/tlperl/lib/Test/Tester/Delegate.pm b/Master/tlpkg/tlperl/lib/Test/Tester/Delegate.pm index 7ddb921cdfc..ed627db442a 100644 --- a/Master/tlpkg/tlperl/lib/Test/Tester/Delegate.pm +++ b/Master/tlpkg/tlperl/lib/Test/Tester/Delegate.pm @@ -3,6 +3,10 @@ use warnings; package Test::Tester::Delegate; +our $VERSION = '1.302073'; + +use Scalar::Util(); + use vars '$AUTOLOAD'; sub new @@ -29,4 +33,13 @@ sub AUTOLOAD goto &$ref; } +sub can { + my $this = shift; + my ($sub) = @_; + + return $this->{Object}->can($sub) if Scalar::Util::blessed($this); + + return $this->SUPER::can(@_); +} + 1; diff --git a/Master/tlpkg/tlperl/lib/Test/use/ok.pm b/Master/tlpkg/tlperl/lib/Test/use/ok.pm index 87d7cc52a55..fdc7326b3de 100644 --- a/Master/tlpkg/tlperl/lib/Test/use/ok.pm +++ b/Master/tlpkg/tlperl/lib/Test/use/ok.pm @@ -1,6 +1,8 @@ package Test::use::ok; use 5.005; -$Test::use::ok::VERSION = '0.16'; + +our $VERSION = '1.302073'; + __END__ |