From 34a8597760ab5740abd49b6d8be10e1876f5ce98 Mon Sep 17 00:00:00 2001 From: Karl Berry Date: Thu, 8 Mar 2018 00:16:42 +0000 Subject: (tl)perl 5.26.1 from siep git-svn-id: svn://tug.org/texlive/trunk@46882 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/tlperl/lib/Test2/API.pm | 1310 ++++++++++++++++++++ Master/tlpkg/tlperl/lib/Test2/API/Breakage.pm | 175 +++ Master/tlpkg/tlperl/lib/Test2/API/Context.pm | 739 +++++++++++ Master/tlpkg/tlperl/lib/Test2/API/Instance.pm | 754 +++++++++++ Master/tlpkg/tlperl/lib/Test2/API/Stack.pm | 220 ++++ Master/tlpkg/tlperl/lib/Test2/Event.pm | 254 ++++ Master/tlpkg/tlperl/lib/Test2/Event/Bail.pm | 102 ++ Master/tlpkg/tlperl/lib/Test2/Event/Diag.pm | 83 ++ Master/tlpkg/tlperl/lib/Test2/Event/Encoding.pm | 86 ++ Master/tlpkg/tlperl/lib/Test2/Event/Exception.pm | 88 ++ Master/tlpkg/tlperl/lib/Test2/Event/Generic.pm | 263 ++++ Master/tlpkg/tlperl/lib/Test2/Event/Info.pm | 127 ++ Master/tlpkg/tlperl/lib/Test2/Event/Note.pm | 81 ++ Master/tlpkg/tlperl/lib/Test2/Event/Ok.pm | 140 +++ Master/tlpkg/tlperl/lib/Test2/Event/Plan.pm | 160 +++ Master/tlpkg/tlperl/lib/Test2/Event/Skip.pm | 108 ++ Master/tlpkg/tlperl/lib/Test2/Event/Subtest.pm | 131 ++ Master/tlpkg/tlperl/lib/Test2/Event/TAP/Version.pm | 83 ++ Master/tlpkg/tlperl/lib/Test2/Event/Waiting.pm | 61 + Master/tlpkg/tlperl/lib/Test2/Formatter.pm | 128 ++ Master/tlpkg/tlperl/lib/Test2/Formatter/TAP.pm | 538 ++++++++ Master/tlpkg/tlperl/lib/Test2/Hub.pm | 829 +++++++++++++ Master/tlpkg/tlperl/lib/Test2/Hub/Interceptor.pm | 80 ++ .../tlperl/lib/Test2/Hub/Interceptor/Terminator.pm | 51 + Master/tlpkg/tlperl/lib/Test2/Hub/Subtest.pm | 125 ++ Master/tlpkg/tlperl/lib/Test2/IPC.pm | 140 +++ Master/tlpkg/tlperl/lib/Test2/IPC/Driver.pm | 292 +++++ Master/tlpkg/tlperl/lib/Test2/IPC/Driver/Files.pm | 497 ++++++++ Master/tlpkg/tlperl/lib/Test2/Tools/Tiny.pm | 425 +++++++ Master/tlpkg/tlperl/lib/Test2/Transition.pod | 512 ++++++++ Master/tlpkg/tlperl/lib/Test2/Util.pm | 258 ++++ Master/tlpkg/tlperl/lib/Test2/Util/ExternalMeta.pm | 182 +++ Master/tlpkg/tlperl/lib/Test2/Util/HashBase.pm | 289 +++++ Master/tlpkg/tlperl/lib/Test2/Util/Trace.pm | 186 +++ 34 files changed, 9497 insertions(+) create mode 100755 Master/tlpkg/tlperl/lib/Test2/API.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/API/Breakage.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/API/Context.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/API/Instance.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/API/Stack.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Event.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Event/Bail.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Event/Diag.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Event/Encoding.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Event/Exception.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Event/Generic.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Event/Info.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Event/Note.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Event/Ok.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Event/Plan.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Event/Skip.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Event/Subtest.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Event/TAP/Version.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Event/Waiting.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Formatter.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Formatter/TAP.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Hub.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Hub/Interceptor.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Hub/Interceptor/Terminator.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Hub/Subtest.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/IPC.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/IPC/Driver.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/IPC/Driver/Files.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Tools/Tiny.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Transition.pod create mode 100755 Master/tlpkg/tlperl/lib/Test2/Util.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Util/ExternalMeta.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Util/HashBase.pm create mode 100755 Master/tlpkg/tlperl/lib/Test2/Util/Trace.pm (limited to 'Master/tlpkg/tlperl/lib/Test2') diff --git a/Master/tlpkg/tlperl/lib/Test2/API.pm b/Master/tlpkg/tlperl/lib/Test2/API.pm new file mode 100755 index 00000000000..41cd0af209e --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/API.pm @@ -0,0 +1,1310 @@ +package Test2::API; +use strict; +use warnings; + +BEGIN { + $ENV{TEST_ACTIVE} ||= 1; + $ENV{TEST2_ACTIVE} = 1; +} + +our $VERSION = '1.302073'; + + +my $INST; +my $ENDING = 0; +sub test2_set_is_end { ($ENDING) = @_ ? @_ : (1) } +sub test2_get_is_end { $ENDING } + +use Test2::API::Instance(\$INST); +# Set the exit status +END { + test2_set_is_end(); # See gh #16 + $INST->set_exit(); +} + +# See gh #16 +{ + no warnings; + INIT { eval 'END { test2_set_is_end() }; 1' or die $@ } +} + +BEGIN { + no warnings 'once'; + if($] ge '5.014' || $ENV{T2_CHECK_DEPTH} || $Test2::API::DO_DEPTH_CHECK) { + *DO_DEPTH_CHECK = sub() { 1 }; + } + else { + *DO_DEPTH_CHECK = sub() { 0 }; + } +} + +use Test2::Util::Trace(); + +use Test2::Hub::Subtest(); +use Test2::Hub::Interceptor(); +use Test2::Hub::Interceptor::Terminator(); + +use Test2::Event::Ok(); +use Test2::Event::Diag(); +use Test2::Event::Note(); +use Test2::Event::Plan(); +use Test2::Event::Bail(); +use Test2::Event::Exception(); +use Test2::Event::Waiting(); +use Test2::Event::Skip(); +use Test2::Event::Subtest(); + +use Carp qw/carp croak confess longmess/; +use Scalar::Util qw/blessed weaken/; +use Test2::Util qw/get_tid/; + +our @EXPORT_OK = qw{ + context release + context_do + no_context + intercept + run_subtest + + test2_init_done + test2_load_done + + test2_set_is_end + test2_get_is_end + + test2_pid + test2_tid + test2_stack + test2_no_wait + + test2_add_callback_context_aquire + test2_add_callback_context_acquire + test2_add_callback_context_init + test2_add_callback_context_release + test2_add_callback_exit + test2_add_callback_post_load + test2_list_context_aquire_callbacks + test2_list_context_acquire_callbacks + test2_list_context_init_callbacks + test2_list_context_release_callbacks + test2_list_exit_callbacks + test2_list_post_load_callbacks + + test2_ipc + test2_ipc_drivers + test2_ipc_add_driver + test2_ipc_polling + test2_ipc_disable_polling + test2_ipc_enable_polling + test2_ipc_get_pending + test2_ipc_set_pending + test2_ipc_enable_shm + + test2_formatter + test2_formatters + test2_formatter_add + test2_formatter_set +}; +BEGIN { require Exporter; our @ISA = qw(Exporter) } + +my $STACK = $INST->stack; +my $CONTEXTS = $INST->contexts; +my $INIT_CBS = $INST->context_init_callbacks; +my $ACQUIRE_CBS = $INST->context_acquire_callbacks; + +sub test2_init_done { $INST->finalized } +sub test2_load_done { $INST->loaded } + +sub test2_pid { $INST->pid } +sub test2_tid { $INST->tid } +sub test2_stack { $INST->stack } +sub test2_no_wait { + $INST->set_no_wait(@_) if @_; + $INST->no_wait; +} + +sub test2_add_callback_context_acquire { $INST->add_context_acquire_callback(@_) } +sub test2_add_callback_context_aquire { $INST->add_context_acquire_callback(@_) } +sub test2_add_callback_context_init { $INST->add_context_init_callback(@_) } +sub test2_add_callback_context_release { $INST->add_context_release_callback(@_) } +sub test2_add_callback_exit { $INST->add_exit_callback(@_) } +sub test2_add_callback_post_load { $INST->add_post_load_callback(@_) } +sub test2_list_context_aquire_callbacks { @{$INST->context_acquire_callbacks} } +sub test2_list_context_acquire_callbacks { @{$INST->context_acquire_callbacks} } +sub test2_list_context_init_callbacks { @{$INST->context_init_callbacks} } +sub test2_list_context_release_callbacks { @{$INST->context_release_callbacks} } +sub test2_list_exit_callbacks { @{$INST->exit_callbacks} } +sub test2_list_post_load_callbacks { @{$INST->post_load_callbacks} } + +sub test2_ipc { $INST->ipc } +sub test2_ipc_add_driver { $INST->add_ipc_driver(@_) } +sub test2_ipc_drivers { @{$INST->ipc_drivers} } +sub test2_ipc_polling { $INST->ipc_polling } +sub test2_ipc_enable_polling { $INST->enable_ipc_polling } +sub test2_ipc_disable_polling { $INST->disable_ipc_polling } +sub test2_ipc_get_pending { $INST->get_ipc_pending } +sub test2_ipc_set_pending { $INST->set_ipc_pending(@_) } +sub test2_ipc_enable_shm { $INST->ipc_enable_shm } + +sub test2_formatter { $INST->formatter } +sub test2_formatters { @{$INST->formatters} } +sub test2_formatter_add { $INST->add_formatter(@_) } +sub test2_formatter_set { + my ($formatter) = @_; + croak "No formatter specified" unless $formatter; + croak "Global Formatter already set" if $INST->formatter_set; + $INST->set_formatter($formatter); +} + +# Private, for use in Test2::API::Context +sub _contexts_ref { $INST->contexts } +sub _context_acquire_callbacks_ref { $INST->context_acquire_callbacks } +sub _context_init_callbacks_ref { $INST->context_init_callbacks } +sub _context_release_callbacks_ref { $INST->context_release_callbacks } + +# Private, for use in Test2::IPC +sub _set_ipc { $INST->set_ipc(@_) } + +sub context_do(&;@) { + my $code = shift; + my @args = @_; + + my $ctx = context(level => 1); + + my $want = wantarray; + + my @out; + my $ok = eval { + $want ? @out = $code->($ctx, @args) : + defined($want) ? $out[0] = $code->($ctx, @args) : + $code->($ctx, @args) ; + 1; + }; + my $err = $@; + + $ctx->release; + + die $err unless $ok; + + return @out if $want; + return $out[0] if defined $want; + return; +} + +sub no_context(&;$) { + my ($code, $hid) = @_; + $hid ||= $STACK->top->hid; + + my $ctx = $CONTEXTS->{$hid}; + delete $CONTEXTS->{$hid}; + my $ok = eval { $code->(); 1 }; + my $err = $@; + + $CONTEXTS->{$hid} = $ctx; + weaken($CONTEXTS->{$hid}); + + die $err unless $ok; + + return; +}; + +sub context { + # We need to grab these before anything else to ensure they are not + # changed. + my ($errno, $eval_error, $child_error) = (0 + $!, $@, $?); + + my %params = (level => 0, wrapped => 0, @_); + + # If something is getting a context then the sync system needs to be + # considered loaded... + $INST->load unless $INST->{loaded}; + + croak "context() called, but return value is ignored" + unless defined wantarray; + + my $stack = $params{stack} || $STACK; + my $hub = $params{hub} || (@$stack ? $stack->[-1] : $stack->top); + my $hid = $hub->{hid}; + my $current = $CONTEXTS->{$hid}; + + $_->(\%params) for @$ACQUIRE_CBS; + map $_->(\%params), @{$hub->{_context_acquire}} if $hub->{_context_acquire}; + + # This is for https://github.com/Test-More/test-more/issues/16 + # and https://rt.perl.org/Public/Bug/Display.html?id=127774 + my $phase = ${^GLOBAL_PHASE} || 'NA'; + my $end_phase = $ENDING || $phase eq 'END' || $phase eq 'DESTRUCT'; + + my $level = 1 + $params{level}; + my ($pkg, $file, $line, $sub) = $end_phase ? caller(0) : caller($level); + unless ($pkg || $end_phase) { + confess "Could not find context at depth $level" unless $params{fudge}; + ($pkg, $file, $line, $sub) = caller(--$level) while ($level >= 0 && !$pkg); + } + + my $depth = $level; + $depth++ while DO_DEPTH_CHECK && !$end_phase && (!$current || $depth <= $current->{_depth} + $params{wrapped}) && caller($depth + 1); + $depth -= $params{wrapped}; + my $depth_ok = !DO_DEPTH_CHECK || $end_phase || !$current || $current->{_depth} < $depth; + + if ($current && $params{on_release} && $depth_ok) { + $current->{_on_release} ||= []; + push @{$current->{_on_release}} => $params{on_release}; + } + + # I know this is ugly.... + ($!, $@, $?) = ($errno, $eval_error, $child_error) and return bless( + { + %$current, + _is_canon => undef, + errno => $errno, + eval_error => $eval_error, + child_error => $child_error, + _is_spawn => [$pkg, $file, $line, $sub], + }, + 'Test2::API::Context' + ) if $current && $depth_ok; + + # Handle error condition of bad level + if ($current) { + unless (${$current->{_aborted}}) { + _canon_error($current, [$pkg, $file, $line, $sub, $depth]) + unless $current->{_is_canon}; + + _depth_error($current, [$pkg, $file, $line, $sub, $depth]) + unless $depth_ok; + } + + $current->release if $current->{_is_canon}; + + delete $CONTEXTS->{$hid}; + } + + # Directly bless the object here, calling new is a noticeable performance + # hit with how often this needs to be called. + my $trace = bless( + { + frame => [$pkg, $file, $line, $sub], + pid => $$, + tid => get_tid(), + }, + 'Test2::Util::Trace' + ); + + # Directly bless the object here, calling new is a noticeable performance + # hit with how often this needs to be called. + my $aborted = 0; + $current = bless( + { + _aborted => \$aborted, + stack => $stack, + hub => $hub, + trace => $trace, + _is_canon => 1, + _depth => $depth, + errno => $errno, + eval_error => $eval_error, + child_error => $child_error, + $params{on_release} ? (_on_release => [$params{on_release}]) : (), + }, + 'Test2::API::Context' + ); + + $CONTEXTS->{$hid} = $current; + weaken($CONTEXTS->{$hid}); + + $_->($current) for @$INIT_CBS; + map $_->($current), @{$hub->{_context_init}} if $hub->{_context_init}; + + $params{on_init}->($current) if $params{on_init}; + + ($!, $@, $?) = ($errno, $eval_error, $child_error); + + return $current; +} + +sub _depth_error { + _existing_error(@_, <<" EOT"); +context() was called to retrieve an existing context, however the existing +context was created in a stack frame at the same, or deeper level. This usually +means that a tool failed to release the context when it was finished. + EOT +} + +sub _canon_error { + _existing_error(@_, <<" EOT"); +context() was called to retrieve an existing context, however the existing +context has an invalid internal state (!_canon_count). This should not normally +happen unless something is mucking about with internals... + EOT +} + +sub _existing_error { + my ($ctx, $details, $msg) = @_; + my ($pkg, $file, $line, $sub, $depth) = @$details; + + my $oldframe = $ctx->{trace}->frame; + my $olddepth = $ctx->{_depth}; + + my $mess = longmess(); + + warn <<" EOT"; +$msg +Old context details: + File: $oldframe->[1] + Line: $oldframe->[2] + Tool: $oldframe->[3] + Depth: $olddepth + +New context details: + File: $file + Line: $line + Tool: $sub + Depth: $depth + +Trace: $mess + +Removing the old context and creating a new one... + EOT +} + +sub release($;$) { + $_[0]->release; + return $_[1]; +} + +sub intercept(&) { + my $code = shift; + + my $ctx = context(); + + my $ipc; + if (my $global_ipc = test2_ipc()) { + my $driver = blessed($global_ipc); + $ipc = $driver->new; + } + + my $hub = Test2::Hub::Interceptor->new( + ipc => $ipc, + no_ending => 1, + ); + + my @events; + $hub->listen(sub { push @events => $_[1] }); + + $ctx->stack->top; # Make sure there is a top hub before we begin. + $ctx->stack->push($hub); + + my ($ok, $err) = (1, undef); + T2_SUBTEST_WRAPPER: { + # Do not use 'try' cause it localizes __DIE__ + $ok = eval { $code->(hub => $hub, context => $ctx->snapshot); 1 }; + $err = $@; + + # They might have done 'BEGIN { skip_all => "whatever" }' + if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && $err->isa('Test2::Hub::Interceptor::Terminator'))) { + $ok = 1; + $err = undef; + } + } + + $hub->cull; + $ctx->stack->pop($hub); + + my $trace = $ctx->trace; + $ctx->release; + + die $err unless $ok; + + $hub->finalize($trace, 1) + if $ok + && !$hub->no_ending + && !$hub->ended; + + return \@events; +} + +sub run_subtest { + my ($name, $code, $params, @args) = @_; + + $params = {buffered => $params} unless ref $params; + my $buffered = delete $params->{buffered}; + my $inherit_trace = delete $params->{inherit_trace}; + + my $ctx = context(); + + $ctx->note($name) unless $buffered; + + my $parent = $ctx->hub; + + my $stack = $ctx->stack || $STACK; + my $hub = $stack->new_hub( + class => 'Test2::Hub::Subtest', + %$params, + ); + + my @events; + $hub->set_nested( $parent->isa('Test2::Hub::Subtest') ? $parent->nested + 1 : 1 ); + $hub->listen(sub { push @events => $_[1] }); + + if ($buffered) { + if (my $format = $hub->format) { + my $hide = $format->can('hide_buffered') ? $format->hide_buffered : 1; + $hub->format(undef) if $hide; + } + } + elsif (! $parent->format) { + # If our parent has no format that means we're in a buffered subtest + # and now we're trying to run a streaming subtest. There's really no + # way for that to work, so we need to force the use of a buffered + # subtest here as + # well. https://github.com/Test-More/test-more/issues/721 + $buffered = 1; + } + + if ($inherit_trace) { + my $orig = $code; + $code = sub { + my $st_ctx = Test2::API::Context->new( + trace => $ctx->trace, + hub => $hub, + ); + $st_ctx->do_in_context($orig, @args); + }; + } + + my ($ok, $err, $finished); + T2_SUBTEST_WRAPPER: { + # Do not use 'try' cause it localizes __DIE__ + $ok = eval { $code->(@args); 1 }; + $err = $@; + + # 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; + } + } + $stack->pop($hub); + + my $trace = $ctx->trace; + + if (!$finished) { + if(my $bailed = $hub->bailed_out) { + $ctx->bail($bailed->reason); + } + my $code = $hub->exit_code; + $ok = !$code; + $err = "Subtest ended with exit code $code" if $code; + } + + $hub->finalize($trace, 1) + if $ok + && !$hub->no_ending + && !$hub->ended; + + my $pass = $ok && $hub->is_passing; + my $e = $ctx->build_event( + 'Subtest', + pass => $pass, + name => $name, + subtest_id => $hub->id, + buffered => $buffered, + subevents => \@events, + ); + + my $plan_ok = $hub->check_plan; + + $ctx->hub->send($e); + + $ctx->failure_diag($e) unless $e->pass; + + $ctx->diag("Caught exception in subtest: $err") unless $ok; + + $ctx->diag("Bad subtest plan, expected " . $hub->plan . " but ran " . $hub->count) + if defined($plan_ok) && !$plan_ok; + + $ctx->release; + return $pass; +} + +# There is a use-cycle between API and API/Context. Context needs to use some +# API functions as the package is compiling. Test2::API::context() needs +# Test2::API::Context to be loaded, but we cannot 'require' the module there as +# it causes a very noticeable performance impact with how often context() is +# called. +require Test2::API::Context; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::API - Primary interface for writing Test2 based testing tools. + +=head1 ***INTERNALS NOTE*** + +B The public +methods provided will not change in backwards-incompatible ways (once there is +a stable release), but the underlying implementation details might. +B + +Currently the implementation is to create a single instance of the +L Object. All class methods defer to the single +instance. There is no public access to the singleton, and that is intentional. +The class methods provided by this package provide the only functionality +publicly exposed. + +This is done primarily to avoid the problems Test::Builder had by exposing its +singleton. We do not want anyone to replace this singleton, rebless it, or +directly muck with its internals. If you need to do something and cannot +because of the restrictions placed here, then please report it as an issue. If +possible, we will create a way for you to implement your functionality without +exposing things that should not be exposed. + +=head1 DESCRIPTION + +This package exports all the functions necessary to write and/or verify testing +tools. Using these building blocks you can begin writing test tools very +quickly. You are also provided with tools that help you to test the tools you +write. + +=head1 SYNOPSIS + +=head2 WRITING A TOOL + +The C method is your primary interface into the Test2 framework. + + package My::Ok; + use Test2::API qw/context/; + + our @EXPORT = qw/my_ok/; + use base 'Exporter'; + + # Just like ok() from Test::More + sub my_ok($;$) { + my ($bool, $name) = @_; + my $ctx = context(); # Get a context + $ctx->ok($bool, $name); + $ctx->release; # Release the context + return $bool; + } + +See L for a list of methods available on the context object. + +=head2 TESTING YOUR TOOLS + +The C tool lets you temporarily intercept all events +generated by the test system: + + use Test2::API qw/intercept/; + + use My::Ok qw/my_ok/; + + my $events = intercept { + # These events are not displayed + my_ok(1, "pass"); + my_ok(0, "fail"); + }; + + my_ok(@$events == 2, "got 2 events, the pass and the fail"); + my_ok($events->[0]->pass, "first event passed"); + my_ok(!$events->[1]->pass, "second event failed"); + +=head2 OTHER API FUNCTIONS + + use Test2::API qw{ + test2_init_done + test2_stack + test2_set_is_end + test2_get_is_end + test2_ipc + test2_formatter_set + test2_formatter + }; + + my $init = test2_init_done(); + my $stack = test2_stack(); + my $ipc = test2_ipc(); + + test2_formatter_set($FORMATTER) + my $formatter = test2_formatter(); + + ... And others ... + +=head1 MAIN API EXPORTS + +All exports are optional. You must specify subs to import. + + use Test2::API qw/context intercept run_subtest/; + +This is the list of exports that are most commonly needed. If you are simply +writing a tool, then this is probably all you need. If you need something and +you cannot find it here, then you can also look at L. + +These exports lack the 'test2_' prefix because of how important/common they +are. Exports in the L section have the 'test2_' prefix to +ensure they stand out. + +=head2 context(...) + +Usage: + +=over 4 + +=item $ctx = context() + +=item $ctx = context(%params) + +=back + +The C function will always return the current context. If +there is already a context active, it will be returned. If there is not an +active context, one will be generated. When a context is generated it will +default to using the file and line number where the currently running sub was +called from. + +Please see L for important rules about +what you can and cannot do with a context once it is obtained. + +B This function will throw an exception if you ignore the context object +it returns. + +B On perls 5.14+ a depth check is used to insure there are no context +leaks. This cannot be safely done on older perls due to +L +You can forcefully enable it either by setting C<$ENV{T2_CHECK_DEPTH} = 1> or +C<$Test2::API::DO_DEPTH_CHECK = 1> B loading L. + +=head3 OPTIONAL PARAMETERS + +All parameters to C are optional. + +=over 4 + +=item level => $int + +If you must obtain a context in a sub deeper than your entry point you can use +this to tell it how many EXTRA stack frames to look back. If this option is not +provided the default of C<0> is used. + + sub third_party_tool { + my $sub = shift; + ... # Does not obtain a context + $sub->(); + ... + } + + third_party_tool(sub { + my $ctx = context(level => 1); + ... + $ctx->release; + }); + +=item wrapped => $int + +Use this if you need to write your own tool that wraps a call to C +with the intent that it should return a context object. + + sub my_context { + my %params = ( wrapped => 0, @_ ); + $params{wrapped}++; + my $ctx = context(%params); + ... + return $ctx; + } + + sub my_tool { + my $ctx = my_context(); + ... + $ctx->release; + } + +If you do not do this, then tools you call that also check for a context will +notice that the context they grabbed was created at the same stack depth, which +will trigger protective measures that warn you and destroy the existing +context. + +=item stack => $stack + +Normally C looks at the global hub stack. If you are maintaining +your own L instance you may pass it in to be used +instead of the global one. + +=item hub => $hub + +Use this parameter if you want to obtain the context for a specific hub instead +of whatever one happens to be at the top of the stack. + +=item on_init => sub { ... } + +This lets you provide a callback sub that will be called B if your call +to C generated a new context. The callback B be called if +C is returning an existing context. The only argument passed into +the callback will be the context object itself. + + sub foo { + my $ctx = context(on_init => sub { 'will run' }); + + my $inner = sub { + # This callback is not run since we are getting the existing + # context from our parent sub. + my $ctx = context(on_init => sub { 'will NOT run' }); + $ctx->release; + } + $inner->(); + + $ctx->release; + } + +=item on_release => sub { ... } + +This lets you provide a callback sub that will be called when the context +instance is released. This callback will be added to the returned context even +if an existing context is returned. If multiple calls to context add callbacks, +then all will be called in reverse order when the context is finally released. + + sub foo { + my $ctx = context(on_release => sub { 'will run second' }); + + my $inner = sub { + my $ctx = context(on_release => sub { 'will run first' }); + + # Neither callback runs on this release + $ctx->release; + } + $inner->(); + + # Both callbacks run here. + $ctx->release; + } + +=back + +=head2 release($;$) + +Usage: + +=over 4 + +=item release $ctx; + +=item release $ctx, ...; + +=back + +This is intended as a shortcut that lets you release your context and return a +value in one statement. This function will get your context, and an optional +return value. It will release your context, then return your value. Scalar +context is always assumed. + + sub tool { + my $ctx = context(); + ... + + return release $ctx, 1; + } + +This tool is most useful when you want to return the value you get from calling +a function that needs to see the current context: + + my $ctx = context(); + my $out = some_tool(...); + $ctx->release; + return $out; + +We can combine the last 3 lines of the above like so: + + my $ctx = context(); + release $ctx, some_tool(...); + +=head2 context_do(&;@) + +Usage: + + sub my_tool { + context_do { + my $ctx = shift; + + my (@args) = @_; + + $ctx->ok(1, "pass"); + + ... + + # No need to call $ctx->release, done for you on scope exit. + } @_; + } + +Using this inside your test tool takes care of a lot of boilerplate for you. It +will ensure a context is acquired. It will capture and rethrow any exception. It +will insure the context is released when you are done. It preserves the +subroutine call context (array, scalar, void). + +This is the safest way to write a test tool. The only two downsides to this are a +slight performance decrease, and some extra indentation in your source. If the +indentation is a problem for you then you can take a peek at the next section. + +=head2 no_context(&;$) + +Usage: + +=over 4 + +=item no_context { ... }; + +=item no_context { ... } $hid; + + sub my_tool(&) { + my $code = shift; + my $ctx = context(); + ... + + no_context { + # Things in here will not see our current context, they get a new + # one. + + $code->(); + }; + + ... + $ctx->release; + }; + +=back + +This tool will hide a context for the provided block of code. This means any +tools run inside the block will get a completely new context if they acquire +one. The new context will be inherited by tools nested below the one that +acquired it. + +This will normally hide the current context for the top hub. If you need to +hide the context for a different hub you can pass in the optional C<$hid> +parameter. + +=head2 intercept(&) + +Usage: + + my $events = intercept { + ok(1, "pass"); + ok(0, "fail"); + ... + }; + +This function takes a codeblock as its only argument, and it has a prototype. +It will execute the codeblock, intercepting any generated events in the +process. It will return an array reference with all the generated event +objects. All events should be subclasses of L. + +This is a very low-level subtest tool. This is useful for writing tools which +produce subtests. This is not intended for people simply writing tests. + +=head2 run_subtest(...) + +Usage: + + run_subtest($NAME, \&CODE, $BUFFERED, @ARGS) + + # or + + run_subtest($NAME, \&CODE, \%PARAMS, @ARGS) + +This will run the provided codeblock with the args in C<@args>. This codeblock +will be run as a subtest. A subtest is an isolated test state that is condensed +into a single L event, which contains all events +generated inside the subtest. + +=head3 ARGUMENTS: + +=over 4 + +=item $NAME + +The name of the subtest. + +=item \&CODE + +The code to run inside the subtest. + +=item $BUFFERED or \%PARAMS + +If this is a simple scalar then it will be treated as a boolean for the +'buffered' setting. If this is a hash reference then it will be used as a +parameters hash. The param hash will be used for hub construction (with the +specified keys removed). + +Keys that are removed and used by run_subtest: + +=over 4 + +=item 'buffered' => $bool + +Toggle buffered status. + +=item 'inherit_trace' => $bool + +Normally the subtest hub is pushed and the sub is allowed to generate its own +root context for the hub. When this setting is turned on a root context will be +created for the hub that shares the same trace as the current context. + +Set this to true if your tool is producing subtests without user-specified +subs. + +=back + +=item @ARGS + +Any extra arguments you want passed into the subtest code. + +=back + +=head3 BUFFERED VS UNBUFFERED (OR STREAMED) + +Normally all events inside and outside a subtest are sent to the formatter +immediately by the hub. Sometimes it is desirable to hold off sending events +within a subtest until the subtest is complete. This usually depends on the +formatter being used. + +=over 4 + +=item Things not effected by this flag + +In both cases events are generated and stored in an array. This array is +eventually used to populate the C attribute on the +L event that is generated at the end of the subtest. +This flag has no effect on this part, it always happens. + +At the end of the subtest, the final L event is sent to +the formatter. + +=item Things that are effected by this flag + +The C attribute of the L event will be set to +the value of this flag. This means any formatter, listener, etc which looks at +the event will know if it was buffered. + +=item Things that are formatter dependant + +Events within a buffered subtest may or may not be sent to the formatter as +they happen. If a formatter fails to specify then the default is to B +the events as they are generated, instead the formatter can pull them from the +C attribute. + +A formatter can specify by implementing the C method. If this +method returns true then events generated inside a buffered subtest will not be +sent independently of the final subtest event. + +=back + +An example of how this is used is the L formatter. For +unbuffered subtests the events are rendered as they are generated. At the end +of the subtest, the final subtest event is rendered, but the C +attribute is ignored. For buffered subtests the opposite occurs, the events are +NOT rendered as they are generated, instead the C attribute is used +to render them all at once. This is useful when running subtests tests in +parallel, since without it the output from subtests would be interleaved +together. + +=head1 OTHER API EXPORTS + +Exports in this section are not commonly needed. These all have the 'test2_' +prefix to help ensure they stand out. You should look at the L section before looking here. This section is one where "Great power +comes with great responsibility". It is possible to break things badly if you +are not careful with these. + +All exports are optional. You need to list which ones you want at import time: + + use Test2::API qw/test2_init_done .../; + +=head2 STATUS AND INITIALIZATION STATE + +These provide access to internal state and object instances. + +=over 4 + +=item $bool = test2_init_done() + +This will return true if the stack and IPC instances have already been +initialized. It will return false if they have not. Init happens as late as +possible. It happens as soon as a tool requests the IPC instance, the +formatter, or the stack. + +=item $bool = test2_load_done() + +This will simply return the boolean value of the loaded flag. If Test2 has +finished loading this will be true, otherwise false. Loading is considered +complete the first time a tool requests a context. + +=item test2_set_is_end() + +=item test2_set_is_end($bool) + +This is used to toggle Test2's belief that the END phase has already started. +With no arguments this will set it to true. With arguments it will set it to +the first argument's value. + +This is used to prevent the use of C in END blocks which can cause +segfaults. This is only necessary in some persistent environments that may have +multiple END phases. + +=item $bool = test2_get_is_end() + +Check if Test2 believes it is the END phase. + +=item $stack = test2_stack() + +This will return the global L instance. If this has not +yet been initialized it will be initialized now. + +=item $bool = test2_no_wait() + +=item test2_no_wait($bool) + +This can be used to get/set the no_wait status. Waiting is turned on by +default. Waiting will cause the parent process/thread to wait until all child +processes and threads are finished before exiting. You will almost never want +to turn this off. + +=back + +=head2 BEHAVIOR HOOKS + +These are hooks that allow you to add custom behavior to actions taken by Test2 +and tools built on top of it. + +=over 4 + +=item test2_add_callback_exit(sub { ... }) + +This can be used to add a callback that is called after all testing is done. This +is too late to add additional results, the main use of this callback is to set the +exit code. + + test2_add_callback_exit( + sub { + my ($context, $exit, \$new_exit) = @_; + ... + } + ); + +The C<$context> passed in will be an instance of L. The +C<$exit> argument will be the original exit code before anything modified it. +C<$$new_exit> is a reference to the new exit code. You may modify this to +change the exit code. Please note that C<$$new_exit> may already be different +from C<$exit> + +=item test2_add_callback_post_load(sub { ... }) + +Add a callback that will be called when Test2 is finished loading. This +means the callback will be run once, the first time a context is obtained. +If Test2 has already finished loading then the callback will be run immediately. + +=item test2_add_callback_context_acquire(sub { ... }) + +Add a callback that will be called every time someone tries to acquire a +context. This will be called on EVERY call to C. It gets a single +argument, a reference to the hash of parameters being used the construct the +context. This is your chance to change the parameters by directly altering the +hash. + + test2_add_callback_context_acquire(sub { + my $params = shift; + $params->{level}++; + }); + +This is a very scary API function. Please do not use this unless you need to. +This is here for L and backwards compatibility. This has you +directly manipulate the hash instead of returning a new one for performance +reasons. + +=item test2_add_callback_context_init(sub { ... }) + +Add a callback that will be called every time a new context is created. The +callback will receive the newly created context as its only argument. + +=item test2_add_callback_context_release(sub { ... }) + +Add a callback that will be called every time a context is released. The +callback will receive the released context as its only argument. + +=item @list = test2_list_context_acquire_callbacks() + +Return all the context acquire callback references. + +=item @list = test2_list_context_init_callbacks() + +Returns all the context init callback references. + +=item @list = test2_list_context_release_callbacks() + +Returns all the context release callback references. + +=item @list = test2_list_exit_callbacks() + +Returns all the exit callback references. + +=item @list = test2_list_post_load_callbacks() + +Returns all the post load callback references. + +=back + +=head2 IPC AND CONCURRENCY + +These let you access, or specify, the IPC system internals. + +=over 4 + +=item $ipc = test2_ipc() + +This will return the global L instance. If this has not yet +been initialized it will be initialized now. + +=item test2_ipc_add_driver($DRIVER) + +Add an IPC driver to the list. This will add the driver to the start of the +list. + +=item @drivers = test2_ipc_drivers() + +Get the list of IPC drivers. + +=item $bool = test2_ipc_polling() + +Check if polling is enabled. + +=item test2_ipc_enable_polling() + +Turn on polling. This will cull events from other processes and threads every +time a context is created. + +=item test2_ipc_disable_polling() + +Turn off IPC polling. + +=item test2_ipc_enable_shm() + +Turn on IPC SHM. Only some IPC drivers use this, and most will turn it on +themselves. + +=item test2_ipc_set_pending($uniq_val) + +Tell other processes and events that an event is pending. C<$uniq_val> should +be a unique value no other thread/process will generate. + +B After calling this C will return 1. This is +intentional, and not avoidable. + +=item $pending = test2_ipc_get_pending() + +This returns -1 if there is no way to check (assume yes) + +This returns 0 if there are (most likely) no pending events. + +This returns 1 if there are (likely) pending events. Upon return it will reset, +nothing else will be able to see that there were pending events. + +=back + +=head2 MANAGING FORMATTERS + +These let you access, or specify, the formatters that can/should be used. + +=over 4 + +=item $formatter = test2_formatter + +This will return the global formatter class. This is not an instance. By +default the formatter is set to L. + +You can override this default using the C environment variable. + +Normally 'Test2::Formatter::' is prefixed to the value in the +environment variable: + + $ T2_FORMATTER='TAP' perl test.t # Use the Test2::Formatter::TAP formatter + $ T2_FORMATTER='Foo' perl test.t # Use the Test2::Formatter::Foo formatter + +If you want to specify a full module name you use the '+' prefix: + + $ T2_FORMATTER='+Foo::Bar' perl test.t # Use the Foo::Bar formatter + +=item test2_formatter_set($class_or_instance) + +Set the global formatter class. This can only be set once. B This will +override anything specified in the 'T2_FORMATTER' environment variable. + +=item @formatters = test2_formatters() + +Get a list of all loaded formatters. + +=item test2_formatter_add($class_or_instance) + +Add a formatter to the list. Last formatter added is used at initialization. If +this is called after initialization a warning will be issued. + +=back + +=head1 OTHER EXAMPLES + +See the C directory included in this distribution. + +=head1 SEE ALSO + +L - Detailed documentation of the context object. + +L - The IPC system used for threading/fork support. + +L - Formatters such as TAP live here. + +L - Events live in this namespace. + +L - All events eventually funnel through a hub. Custom hubs are how +C and C are implemented. + +=head1 MAGIC + +This package has an END block. This END block is responsible for setting the +exit code based on the test results. This end block also calls the callbacks that +can be added to this package. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/API/Breakage.pm b/Master/tlpkg/tlperl/lib/Test2/API/Breakage.pm new file mode 100755 index 00000000000..b85e4d54c9f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/API/Breakage.pm @@ -0,0 +1,175 @@ +package Test2::API::Breakage; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +use Test2::Util qw/pkg_to_file/; + +our @EXPORT_OK = qw{ + upgrade_suggested + upgrade_required + known_broken +}; +BEGIN { require Exporter; our @ISA = qw(Exporter) } + +sub upgrade_suggested { + return ( + 'Test::Exception' => '0.42', + 'Test::FITesque' => '0.04', + 'Test::Module::Used' => '0.2.5', + 'Test::Moose::More' => '0.025', + ); +} + +sub upgrade_required { + return ( + 'Test::Builder::Clutch' => '0.07', + 'Test::Dist::VersionSync' => '1.1.4', + 'Test::Modern' => '0.012', + 'Test::SharedFork' => '0.34', + 'Test::Alien' => '0.04', + 'Test::UseAllModules' => '0.14', + + 'Test::Clustericious::Cluster' => '0.30', + ); +} + +sub known_broken { + return ( + 'Net::BitTorrent' => '0.052', + 'Test::Able' => '0.11', + 'Test::Aggregate' => '0.373', + 'Test::Flatten' => '0.11', + 'Test::Group' => '0.20', + 'Test::More::Prefix' => '0.005', + 'Test::ParallelSubtest' => '0.05', + 'Test::Pretty' => '0.32', + 'Test::Wrapper' => '0.3.0', + + 'Test::DBIx::Class::Schema' => '1.0.9', + 'Log::Dispatch::Config::TestLog' => '0.02', + ); +} + +# Not reportable: +# Device::Chip => 0.07 - Tests will not pass, but not broken if already installed, also no fixed version we can upgrade to. + +sub report { + my $class = shift; + my ($require) = @_; + + my %suggest = __PACKAGE__->upgrade_suggested(); + my %required = __PACKAGE__->upgrade_required(); + my %broken = __PACKAGE__->known_broken(); + + my @warn; + for my $mod (keys %suggest) { + my $file = pkg_to_file($mod); + next unless $INC{$file} || ($require && eval { require $file; 1 }); + my $want = $suggest{$mod}; + next if eval { $mod->VERSION($want); 1 }; + push @warn => " * Module '$mod' is outdated, we recommed updating above $want."; + } + + for my $mod (keys %required) { + my $file = pkg_to_file($mod); + next unless $INC{$file} || ($require && eval { require $file; 1 }); + my $want = $required{$mod}; + next if eval { $mod->VERSION($want); 1 }; + push @warn => " * Module '$mod' is outdated and known to be broken, please update to $want or higher."; + } + + for my $mod (keys %broken) { + my $file = pkg_to_file($mod); + next unless $INC{$file} || ($require && eval { require $file; 1 }); + my $tested = $broken{$mod}; + push @warn => " * Module '$mod' is known to be broken in version $tested and below, newer versions have not been tested. You have: " . $mod->VERSION; + } + + return @warn; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::API::Breakage - What breaks at what version + +=head1 DESCRIPTION + +This module provides lists of modules that are broken, or have been broken in +the past, when upgrading L to use L. + +=head1 FUNCTIONS + +These can be imported, or called as methods on the class. + +=over 4 + +=item %mod_ver = upgrade_suggested() + +=item %mod_ver = Test2::API::Breakage->upgrade_suggested() + +This returns key/value pairs. The key is the module name, the value is the +version number. If the installed version of the module is at or below the +specified one then an upgrade would be a good idea, but not strictly necessary. + +=item %mod_ver = upgrade_required() + +=item %mod_ver = Test2::API::Breakage->upgrade_required() + +This returns key/value pairs. The key is the module name, the value is the +version number. If the installed version of the module is at or below the +specified one then an upgrade is required for the module to work properly. + +=item %mod_ver = known_broken() + +=item %mod_ver = Test2::API::Breakage->known_broken() + +This returns key/value pairs. The key is the module name, the value is the +version number. If the installed version of the module is at or below the +specified one then the module will not work. A newer version may work, but is +not tested or verified. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/API/Context.pm b/Master/tlpkg/tlperl/lib/Test2/API/Context.pm new file mode 100755 index 00000000000..7660fa69ea2 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/API/Context.pm @@ -0,0 +1,739 @@ +package Test2::API::Context; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +use Carp qw/confess croak longmess/; +use Scalar::Util qw/weaken blessed/; +use Test2::Util qw/get_tid try pkg_to_file get_tid/; + +use Test2::Util::Trace(); +use Test2::API(); + +# Preload some key event types +my %LOADED = ( + map { + my $pkg = "Test2::Event::$_"; + my $file = "Test2/Event/$_.pm"; + require $file unless $INC{$file}; + ( $pkg => $pkg, $_ => $pkg ) + } qw/Ok Diag Note Info Plan Bail Exception Waiting Skip Subtest/ +); + +use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; +use Test2::Util::HashBase qw{ + stack hub trace _on_release _depth _is_canon _is_spawn _aborted + errno eval_error child_error thrown +}; + +# Private, not package vars +# It is safe to cache these. +my $ON_RELEASE = Test2::API::_context_release_callbacks_ref(); +my $CONTEXTS = Test2::API::_contexts_ref(); + +sub init { + my $self = shift; + + confess "The 'trace' attribute is required" + unless $self->{+TRACE}; + + confess "The 'hub' attribute is required" + unless $self->{+HUB}; + + $self->{+_DEPTH} = 0 unless defined $self->{+_DEPTH}; + + $self->{+ERRNO} = $! unless exists $self->{+ERRNO}; + $self->{+EVAL_ERROR} = $@ unless exists $self->{+EVAL_ERROR}; + $self->{+CHILD_ERROR} = $? unless exists $self->{+CHILD_ERROR}; +} + +sub snapshot { bless {%{$_[0]}, _is_canon => undef, _is_spawn => undef, _aborted => undef}, __PACKAGE__ } + +sub restore_error_vars { + my $self = shift; + ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR}; +} + +sub DESTROY { + return unless $_[0]->{+_IS_CANON} || $_[0]->{+_IS_SPAWN}; + return if $_[0]->{+_ABORTED} && ${$_[0]->{+_ABORTED}}; + my ($self) = @_; + + my $hub = $self->{+HUB}; + my $hid = $hub->{hid}; + + # Do not show the warning if it looks like an exception has been thrown, or + # if the context is not local to this process or thread. + { + # Sometimes $@ is uninitialized, not a problem in this case so do not + # show the warning about using eq. + no warnings 'uninitialized'; + if($self->{+EVAL_ERROR} eq $@ && $hub->is_local) { + my $frame = $self->{+_IS_SPAWN} || $self->{+TRACE}->frame; + warn <<" EOT"; +A context appears to have been destroyed without first calling release(). +Based on \$@ it does not look like an exception was thrown (this is not always +a reliable test) + +This is a problem because the global error variables (\$!, \$@, and \$?) will +not be restored. In addition some release callbacks will not work properly from +inside a DESTROY method. + +Here are the context creation details, just in case a tool forgot to call +release(): + File: $frame->[1] + Line: $frame->[2] + Tool: $frame->[3] + +Cleaning up the CONTEXT stack... + EOT + } + } + + return if $self->{+_IS_SPAWN}; + + # Remove the key itself to avoid a slow memory leak + delete $CONTEXTS->{$hid}; + $self->{+_IS_CANON} = undef; + + if (my $cbk = $self->{+_ON_RELEASE}) { + $_->($self) for reverse @$cbk; + } + if (my $hcbk = $hub->{_context_release}) { + $_->($self) for reverse @$hcbk; + } + $_->($self) for reverse @$ON_RELEASE; +} + +# release exists to implement behaviors like die-on-fail. In die-on-fail you +# want to die after a failure, but only after diagnostics have been reported. +# The ideal time for the die to happen is when the context is released. +# Unfortunately die does not work in a DESTROY block. +sub release { + my ($self) = @_; + + ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} and return if $self->{+THROWN}; + + ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} and return $self->{+_IS_SPAWN} = undef + if $self->{+_IS_SPAWN}; + + croak "release() should not be called on context that is neither canon nor a child" + unless $self->{+_IS_CANON}; + + my $hub = $self->{+HUB}; + my $hid = $hub->{hid}; + + croak "context thinks it is canon, but it is not" + unless $CONTEXTS->{$hid} && $CONTEXTS->{$hid} == $self; + + # Remove the key itself to avoid a slow memory leak + $self->{+_IS_CANON} = undef; + delete $CONTEXTS->{$hid}; + + if (my $cbk = $self->{+_ON_RELEASE}) { + $_->($self) for reverse @$cbk; + } + if (my $hcbk = $hub->{_context_release}) { + $_->($self) for reverse @$hcbk; + } + $_->($self) for reverse @$ON_RELEASE; + + # Do this last so that nothing else changes them. + # If one of the hooks dies then these do not get restored, this is + # intentional + ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR}; + + return; +} + +sub do_in_context { + my $self = shift; + my ($sub, @args) = @_; + + # We need to update the pid/tid and error vars. + my $clone = $self->snapshot; + @$clone{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} = ($!, $@, $?); + $clone->{+TRACE} = $clone->{+TRACE}->snapshot; + $clone->{+TRACE}->set_pid($$); + $clone->{+TRACE}->set_tid(get_tid()); + + my $hub = $clone->{+HUB}; + my $hid = $hub->hid; + + my $old = $CONTEXTS->{$hid}; + + $clone->{+_IS_CANON} = 1; + $CONTEXTS->{$hid} = $clone; + weaken($CONTEXTS->{$hid}); + my ($ok, $err) = &try($sub, @args); + my ($rok, $rerr) = try { $clone->release }; + delete $clone->{+_IS_CANON}; + + if ($old) { + $CONTEXTS->{$hid} = $old; + weaken($CONTEXTS->{$hid}); + } + else { + delete $CONTEXTS->{$hid}; + } + + die $err unless $ok; + die $rerr unless $rok; +} + +sub done_testing { + my $self = shift; + $self->hub->finalize($self->trace, 1); + return; +} + +sub throw { + my ($self, $msg) = @_; + $self->{+THROWN} = 1; + ${$self->{+_ABORTED}}++ if $self->{+_ABORTED}; + $self->release if $self->{+_IS_CANON} || $self->{+_IS_SPAWN}; + $self->trace->throw($msg); +} + +sub alert { + my ($self, $msg) = @_; + $self->trace->alert($msg); +} + +sub send_event { + my $self = shift; + my $event = shift; + my %args = @_; + + my $pkg = $LOADED{$event} || $self->_parse_event($event); + + my $e = $pkg->new( + trace => $self->{+TRACE}->snapshot, + %args, + ); + + ${$self->{+_ABORTED}}++ if $self->{+_ABORTED} && defined $e->terminate; + $self->{+HUB}->send($e); +} + +sub build_event { + my $self = shift; + my $event = shift; + my %args = @_; + + my $pkg = $LOADED{$event} || $self->_parse_event($event); + + $pkg->new( + trace => $self->{+TRACE}->snapshot, + %args, + ); +} + +sub ok { + my $self = shift; + my ($pass, $name, $on_fail) = @_; + + my $hub = $self->{+HUB}; + + my $e = bless { + trace => bless( {%{$self->{+TRACE}}}, 'Test2::Util::Trace'), + pass => $pass, + name => $name, + }, 'Test2::Event::Ok'; + $e->init; + + $hub->send($e); + return $e if $pass; + + $self->failure_diag($e); + + if ($on_fail && @$on_fail) { + for my $of (@$on_fail) { + if (ref($of) eq 'CODE' || (blessed($of) && $of->can('render'))) { + $self->info($of, diagnostics => 1); + } + else { + $self->diag($of); + } + } + } + + return $e; +} + +sub failure_diag { + my $self = shift; + my ($e) = @_; + + # This behavior is inherited from Test::Builder which injected a newline at + # the start of the first diagnostics when the harness is active, but not + # verbose. This is important to keep the diagnostics from showing up + # appended to the existing line, which is hard to read. In a verbose + # harness there is no need for this. + my $prefix = $ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_IS_VERBOSE} ? "\n" : ""; + + # Figure out the debug info, this is typically the file name and line + # number, but can also be a custom message. If no trace object is provided + # then we have nothing useful to display. + my $name = $e->name; + my $trace = $e->trace; + my $debug = $trace ? $trace->debug : "[No trace info available]"; + + # Create the initial diagnostics. If the test has a name we put the debug + # info on a second line, this behavior is inherited from Test::Builder. + my $msg = defined($name) + ? qq[${prefix}Failed test '$name'\n$debug.\n] + : qq[${prefix}Failed test $debug.\n]; + + $self->diag($msg); +} + +sub skip { + my $self = shift; + my ($name, $reason, @extra) = @_; + $self->send_event( + 'Skip', + name => $name, + reason => $reason, + pass => 1, + @extra, + ); +} + +sub info { + my $self = shift; + my ($renderer, %params) = @_; + $self->send_event('Info', renderer => $renderer, %params); +} + +sub note { + my $self = shift; + my ($message) = @_; + $self->send_event('Note', message => $message); +} + +sub diag { + my $self = shift; + my ($message) = @_; + my $hub = $self->{+HUB}; + $self->send_event( + 'Diag', + message => $message, + ); +} + +sub plan { + my ($self, $max, $directive, $reason) = @_; + $self->send_event('Plan', max => $max, directive => $directive, reason => $reason); +} + +sub bail { + my ($self, $reason) = @_; + $self->send_event('Bail', reason => $reason); +} + +sub _parse_event { + my $self = shift; + my $event = shift; + + my $pkg; + if ($event =~ m/^\+(.*)/) { + $pkg = $1; + } + else { + $pkg = "Test2::Event::$event"; + } + + unless ($LOADED{$pkg}) { + my $file = pkg_to_file($pkg); + my ($ok, $err) = try { require $file }; + $self->throw("Could not load event module '$pkg': $err") + unless $ok; + + $LOADED{$pkg} = $pkg; + } + + confess "'$pkg' is not a subclass of 'Test2::Event'" + unless $pkg->isa('Test2::Event'); + + $LOADED{$event} = $pkg; + + return $pkg; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::API::Context - Object to represent a testing context. + +=head1 DESCRIPTION + +The context object is the primary interface for authors of testing tools +written with L. The context object represents the context in +which a test takes place (File and Line Number), and provides a quick way to +generate events from that context. The context object also takes care of +sending events to the correct L instance. + +=head1 SYNOPSIS + +In general you will not be creating contexts directly. To obtain a context you +should always use C which is exported by the L module. + + use Test2::API qw/context/; + + sub my_ok { + my ($bool, $name) = @_; + my $ctx = context(); + $ctx->ok($bool, $name); + $ctx->release; # You MUST do this! + return $bool; + } + +Context objects make it easy to wrap other tools that also use context. Once +you grab a context, any tool you call before releasing your context will +inherit it: + + sub wrapper { + my ($bool, $name) = @_; + my $ctx = context(); + $ctx->diag("wrapping my_ok"); + + my $out = my_ok($bool, $name); + $ctx->release; # You MUST do this! + return $out; + } + +=head1 CRITICAL DETAILS + +=over 4 + +=item you MUST always use the context() sub from Test2::API + +Creating your own context via C<< Test2::API::Context->new() >> will almost never +produce a desirable result. Use C which is exported by L. + +There are a handful of cases where a tool author may want to create a new +context by hand, which is why the C method exists. Unless you really know +what you are doing you should avoid this. + +=item You MUST always release the context when done with it + +Releasing the context tells the system you are done with it. This gives it a +chance to run any necessary callbacks or cleanup tasks. If you forget to +release the context it will try to detect the problem and warn you about it. + +=item You MUST NOT pass context objects around + +When you obtain a context object it is made specifically for your tool and any +tools nested within. If you pass a context around you run the risk of polluting +other tools with incorrect context information. + +If you are certain that you want a different tool to use the same context you +may pass it a snapshot. C<< $ctx->snapshot >> will give you a shallow clone of +the context that is safe to pass around or store. + +=item You MUST NOT store or cache a context for later + +As long as a context exists for a given hub, all tools that try to get a +context will get the existing instance. If you try to store the context you +will pollute other tools with incorrect context information. + +If you are certain that you want to save the context for later, you can use a +snapshot. C<< $ctx->snapshot >> will give you a shallow clone of the context +that is safe to pass around or store. + +C has some mechanisms to protect you if you do cause a context to +persist beyond the scope in which it was obtained. In practice you should not +rely on these protections, and they are fairly noisy with warnings. + +=item You SHOULD obtain your context as soon as possible in a given tool + +You never know what tools you call from within your own tool will need a +context. Obtaining the context early ensures that nested tools can find the +context you want them to find. + +=back + +=head1 METHODS + +=over 4 + +=item $ctx->done_testing; + +Note that testing is finished. If no plan has been set this will generate a +Plan event. + +=item $clone = $ctx->snapshot() + +This will return a shallow clone of the context. The shallow clone is safe to +store for later. + +=item $ctx->release() + +This will release the context. This runs cleanup tasks, and several important +hooks. It will also restore C<$!>, C<$?>, and C<$@> to what they were when the +context was created. + +B If a context is acquired more than once an internal refcount is kept. +C decrements the ref count, none of the other actions of +C will occur unless the refcount hits 0. This means only the last +call to C will reset C<$?>, C<$!>, C<$@>,and run the cleanup tasks. + +=item $ctx->throw($message) + +This will throw an exception reporting to the file and line number of the +context. This will also release the context for you. + +=item $ctx->alert($message) + +This will issue a warning from the file and line number of the context. + +=item $stack = $ctx->stack() + +This will return the L instance the context used to find +the current hub. + +=item $hub = $ctx->hub() + +This will return the L instance the context recognizes as the +current one to which all events should be sent. + +=item $dbg = $ctx->trace() + +This will return the L instance used by the context. + +=item $ctx->do_in_context(\&code, @args); + +Sometimes you have a context that is not current, and you want things to use it +as the current one. In these cases you can call +C<< $ctx->do_in_context(sub { ... }) >>. The codeblock will be run, and +anything inside of it that looks for a context will find the one on which the +method was called. + +This B affect context on other hubs, only the hub used by the context +will be affected. + + my $ctx = ...; + $ctx->do_in_context(sub { + my $ctx = context(); # returns the $ctx the sub is called on + }); + +B The context will actually be cloned, the clone will be used instead of +the original. This allows the thread id, process id, and error variables to be correct without +modifying the original context. + +=item $ctx->restore_error_vars() + +This will set C<$!>, C<$?>, and C<$@> to what they were when the context was +created. There is no localization or anything done here, calling this method +will actually set these vars. + +=item $! = $ctx->errno() + +The (numeric) value of C<$!> when the context was created. + +=item $? = $ctx->child_error() + +The value of C<$?> when the context was created. + +=item $@ = $ctx->eval_error() + +The value of C<$@> when the context was created. + +=back + +=head2 EVENT PRODUCTION METHODS + +=over 4 + +=item $event = $ctx->ok($bool, $name) + +=item $event = $ctx->ok($bool, $name, \@on_fail) + +This will create an L object for you. If C<$bool> is false +then an L event will be sent as well with details about the +failure. If you do not want automatic diagnostics you should use the +C method directly. + +The third argument C<\@on_fail>) is an optional set of diagnostics to be sent in +the event of a test failure. Plain strings will be sent as +L events. References will be used to construct +L events with C<< diagnostics => 1 >>. + +=item $event = $ctx->info($renderer, diagnostics => $bool, %other_params) + +Send an L. + +=item $event = $ctx->note($message) + +Send an L. This event prints a message to STDOUT. + +=item $event = $ctx->diag($message) + +Send an L. This event prints a message to STDERR. + +=item $event = $ctx->plan($max) + +=item $event = $ctx->plan(0, 'SKIP', $reason) + +This can be used to send an L event. This event +usually takes either a number of tests you expect to run. Optionally you can +set the expected count to 0 and give the 'SKIP' directive with a reason to +cause all tests to be skipped. + +=item $event = $ctx->skip($name, $reason); + +Send an L event. + +=item $event = $ctx->bail($reason) + +This sends an L event. This event will completely +terminate all testing. + +=item $event = $ctx->send_event($Type, %parameters) + +This lets you build and send an event of any type. The C<$Type> argument should +be the event package name with C left off, or a fully +qualified package name prefixed with a '+'. The event is returned after it is +sent. + + my $event = $ctx->send_event('Ok', ...); + +or + + my $event = $ctx->send_event('+Test2::Event::Ok', ...); + +=item $event = $ctx->build_event($Type, %parameters) + +This is the same as C, except it builds and returns the event +without sending it. + +=back + +=head1 HOOKS + +There are 2 types of hooks, init hooks, and release hooks. As the names +suggest, these hooks are triggered when contexts are created or released. + +=head2 INIT HOOKS + +These are called whenever a context is initialized. That means when a new +instance is created. These hooks are B called every time something +requests a context, just when a new one is created. + +=head3 GLOBAL + +This is how you add a global init callback. Global callbacks happen for every +context for any hub or stack. + + Test2::API::test2_add_callback_context_init(sub { + my $ctx = shift; + ... + }); + +=head3 PER HUB + +This is how you add an init callback for all contexts created for a given hub. +These callbacks will not run for other hubs. + + $hub->add_context_init(sub { + my $ctx = shift; + ... + }); + +=head3 PER CONTEXT + +This is how you specify an init hook that will only run if your call to +C generates a new context. The callback will be ignored if +C is returning an existing context. + + my $ctx = context(on_init => sub { + my $ctx = shift; + ... + }); + +=head2 RELEASE HOOKS + +These are called whenever a context is released. That means when the last +reference to the instance is about to be destroyed. These hooks are B +called every time C<< $ctx->release >> is called. + +=head3 GLOBAL + +This is how you add a global release callback. Global callbacks happen for every +context for any hub or stack. + + Test2::API::test2_add_callback_context_release(sub { + my $ctx = shift; + ... + }); + +=head3 PER HUB + +This is how you add a release callback for all contexts created for a given +hub. These callbacks will not run for other hubs. + + $hub->add_context_release(sub { + my $ctx = shift; + ... + }); + +=head3 PER CONTEXT + +This is how you add release callbacks directly to a context. The callback will +B be added to the context that gets returned, it does not matter if a +new one is generated, or if an existing one is returned. + + my $ctx = context(on_release => sub { + my $ctx = shift; + ... + }); + +=head1 THIRD PARTY META-DATA + +This object consumes L which provides a consistent +way for you to attach meta-data to instances of this class. This is useful for +tools, plugins, and other extensions. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=item Kent Fredric Ekentnl@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/API/Instance.pm b/Master/tlpkg/tlperl/lib/Test2/API/Instance.pm new file mode 100755 index 00000000000..70d4cd7bb78 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/API/Instance.pm @@ -0,0 +1,754 @@ +package Test2::API::Instance; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +our @CARP_NOT = qw/Test2::API Test2::API::Instance Test2::IPC::Driver Test2::Formatter/; +use Carp qw/confess carp/; +use Scalar::Util qw/reftype/; + +use Test2::Util qw/get_tid USE_THREADS CAN_FORK pkg_to_file try/; + +use Test2::Util::Trace(); +use Test2::API::Stack(); + +use Test2::Util::HashBase qw{ + _pid _tid + no_wait + finalized loaded + ipc stack formatter + contexts + + ipc_shm_size + ipc_shm_last + ipc_shm_id + ipc_polling + ipc_drivers + formatters + + exit_callbacks + post_load_callbacks + context_acquire_callbacks + context_init_callbacks + context_release_callbacks +}; + +sub pid { $_[0]->{+_PID} ||= $$ } +sub tid { $_[0]->{+_TID} ||= get_tid() } + +# Wrap around the getters that should call _finalize. +BEGIN { + for my $finalizer (IPC, FORMATTER) { + my $orig = __PACKAGE__->can($finalizer); + my $new = sub { + my $self = shift; + $self->_finalize unless $self->{+FINALIZED}; + $self->$orig; + }; + + no strict 'refs'; + no warnings 'redefine'; + *{$finalizer} = $new; + } +} + +sub import { + my $class = shift; + return unless @_; + my ($ref) = @_; + $$ref = $class->new; +} + +sub init { $_[0]->reset } + +sub reset { + my $self = shift; + + delete $self->{+_PID}; + delete $self->{+_TID}; + + $self->{+CONTEXTS} = {}; + + $self->{+IPC_DRIVERS} = []; + $self->{+IPC_POLLING} = undef; + + $self->{+FORMATTERS} = []; + $self->{+FORMATTER} = undef; + + $self->{+FINALIZED} = undef; + $self->{+IPC} = undef; + + $self->{+NO_WAIT} = 0; + $self->{+LOADED} = 0; + + $self->{+EXIT_CALLBACKS} = []; + $self->{+POST_LOAD_CALLBACKS} = []; + $self->{+CONTEXT_ACQUIRE_CALLBACKS} = []; + $self->{+CONTEXT_INIT_CALLBACKS} = []; + $self->{+CONTEXT_RELEASE_CALLBACKS} = []; + + $self->{+STACK} = Test2::API::Stack->new; +} + +sub _finalize { + my $self = shift; + my ($caller) = @_; + $caller ||= [caller(1)]; + + $self->{+FINALIZED} = $caller; + + $self->{+_PID} = $$ unless defined $self->{+_PID}; + $self->{+_TID} = get_tid() unless defined $self->{+_TID}; + + unless ($self->{+FORMATTER}) { + my ($formatter, $source); + if ($ENV{T2_FORMATTER}) { + $source = "set by the 'T2_FORMATTER' environment variable"; + + if ($ENV{T2_FORMATTER} =~ m/^(\+)?(.*)$/) { + $formatter = $1 ? $2 : "Test2::Formatter::$2" + } + else { + $formatter = ''; + } + } + elsif (@{$self->{+FORMATTERS}}) { + ($formatter) = @{$self->{+FORMATTERS}}; + $source = "Most recently added"; + } + else { + $formatter = 'Test2::Formatter::TAP'; + $source = 'default formatter'; + } + + unless (ref($formatter) || $formatter->can('write')) { + my $file = pkg_to_file($formatter); + my ($ok, $err) = try { require $file }; + unless ($ok) { + my $line = "* COULD NOT LOAD FORMATTER '$formatter' ($source) *"; + my $border = '*' x length($line); + die "\n\n $border\n $line\n $border\n\n$err"; + } + } + + $self->{+FORMATTER} = $formatter; + } + + # Turn on IPC if threads are on, drivers are registered, or the Test2::IPC + # module is loaded. + return unless USE_THREADS || $INC{'Test2/IPC.pm'} || @{$self->{+IPC_DRIVERS}}; + + # Turn on polling by default, people expect it. + $self->enable_ipc_polling; + + unless (@{$self->{+IPC_DRIVERS}}) { + my ($ok, $error) = try { require Test2::IPC::Driver::Files }; + die $error unless $ok; + push @{$self->{+IPC_DRIVERS}} => 'Test2::IPC::Driver::Files'; + } + + for my $driver (@{$self->{+IPC_DRIVERS}}) { + next unless $driver->can('is_viable') && $driver->is_viable; + $self->{+IPC} = $driver->new or next; + $self->ipc_enable_shm if $self->{+IPC}->use_shm; + return; + } + + die "IPC has been requested, but no viable drivers were found. Aborting...\n"; +} + +sub formatter_set { $_[0]->{+FORMATTER} ? 1 : 0 } + +sub add_formatter { + my $self = shift; + my ($formatter) = @_; + unshift @{$self->{+FORMATTERS}} => $formatter; + + return unless $self->{+FINALIZED}; + + # Why is the @CARP_NOT entry not enough? + local %Carp::Internal = %Carp::Internal; + $Carp::Internal{'Test2::Formatter'} = 1; + + carp "Formatter $formatter loaded too late to be used as the global formatter"; +} + +sub add_context_acquire_callback { + my $self = shift; + my ($code) = @_; + + my $rtype = reftype($code) || ""; + + confess "Context-acquire callbacks must be coderefs" + unless $code && $rtype eq 'CODE'; + + push @{$self->{+CONTEXT_ACQUIRE_CALLBACKS}} => $code; +} + +sub add_context_init_callback { + my $self = shift; + my ($code) = @_; + + my $rtype = reftype($code) || ""; + + confess "Context-init callbacks must be coderefs" + unless $code && $rtype eq 'CODE'; + + push @{$self->{+CONTEXT_INIT_CALLBACKS}} => $code; +} + +sub add_context_release_callback { + my $self = shift; + my ($code) = @_; + + my $rtype = reftype($code) || ""; + + confess "Context-release callbacks must be coderefs" + unless $code && $rtype eq 'CODE'; + + push @{$self->{+CONTEXT_RELEASE_CALLBACKS}} => $code; +} + +sub add_post_load_callback { + my $self = shift; + my ($code) = @_; + + my $rtype = reftype($code) || ""; + + confess "Post-load callbacks must be coderefs" + unless $code && $rtype eq 'CODE'; + + push @{$self->{+POST_LOAD_CALLBACKS}} => $code; + $code->() if $self->{+LOADED}; +} + +sub load { + my $self = shift; + unless ($self->{+LOADED}) { + $self->{+_PID} = $$ unless defined $self->{+_PID}; + $self->{+_TID} = get_tid() unless defined $self->{+_TID}; + + # This is for https://github.com/Test-More/test-more/issues/16 + # and https://rt.perl.org/Public/Bug/Display.html?id=127774 + # END blocks run in reverse order. This insures the END block is loaded + # as late as possible. It will not solve all cases, but it helps. + eval "END { Test2::API::test2_set_is_end() }; 1" or die $@; + + $self->{+LOADED} = 1; + $_->() for @{$self->{+POST_LOAD_CALLBACKS}}; + } + return $self->{+LOADED}; +} + +sub add_exit_callback { + my $self = shift; + my ($code) = @_; + my $rtype = reftype($code) || ""; + + confess "End callbacks must be coderefs" + unless $code && $rtype eq 'CODE'; + + push @{$self->{+EXIT_CALLBACKS}} => $code; +} + +sub add_ipc_driver { + my $self = shift; + my ($driver) = @_; + unshift @{$self->{+IPC_DRIVERS}} => $driver; + + return unless $self->{+FINALIZED}; + + # Why is the @CARP_NOT entry not enough? + local %Carp::Internal = %Carp::Internal; + $Carp::Internal{'Test2::IPC::Driver'} = 1; + + carp "IPC driver $driver loaded too late to be used as the global ipc driver"; +} + +sub enable_ipc_polling { + my $self = shift; + + $self->{+_PID} = $$ unless defined $self->{+_PID}; + $self->{+_TID} = get_tid() unless defined $self->{+_TID}; + + $self->add_context_init_callback( + # This is called every time a context is created, it needs to be fast. + # $_[0] is a context object + sub { + return unless $self->{+IPC_POLLING}; + return $_[0]->{hub}->cull unless $self->{+IPC_SHM_ID}; + + my $val; + { + shmread($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE}) or return; + + return if $val eq $self->{+IPC_SHM_LAST}; + $self->{+IPC_SHM_LAST} = $val; + } + + $_[0]->{hub}->cull; + } + ) unless defined $self->ipc_polling; + + $self->set_ipc_polling(1); +} + +sub ipc_enable_shm { + my $self = shift; + + return 1 if defined $self->{+IPC_SHM_ID}; + + $self->{+_PID} = $$ unless defined $self->{+_PID}; + $self->{+_TID} = get_tid() unless defined $self->{+_TID}; + + my ($ok, $err) = try { + # SysV IPC can be available but not enabled. + # + # In some systems (*BSD) accessing the SysV IPC APIs without + # them being enabled can cause a SIGSYS. We suppress the SIGSYS + # and then get ENOSYS from the calls. + local $SIG{SYS} = 'IGNORE'; + + require IPC::SysV; + + my $ipc_key = IPC::SysV::IPC_PRIVATE(); + my $shm_size = $self->{+IPC}->can('shm_size') ? $self->{+IPC}->shm_size : 64; + my $shm_id = shmget($ipc_key, $shm_size, 0666) or die; + + my $initial = 'a' x $shm_size; + shmwrite($shm_id, $initial, 0, $shm_size) or die; + + $self->{+IPC_SHM_SIZE} = $shm_size; + $self->{+IPC_SHM_ID} = $shm_id; + $self->{+IPC_SHM_LAST} = $initial; + }; + + return $ok; +} + +sub ipc_free_shm { + my $self = shift; + + my $id = delete $self->{+IPC_SHM_ID}; + return unless defined $id; + + shmctl($id, IPC::SysV::IPC_RMID(), 0); +} + +sub get_ipc_pending { + my $self = shift; + return -1 unless defined $self->{+IPC_SHM_ID}; + my $val; + shmread($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE}) or return -1; + return 0 if $val eq $self->{+IPC_SHM_LAST}; + $self->{+IPC_SHM_LAST} = $val; + return 1; +} + +sub set_ipc_pending { + my $self = shift; + + return undef unless defined $self->{+IPC_SHM_ID}; + + my ($val) = @_; + + confess "value is required for set_ipc_pending" + unless $val; + + shmwrite($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE}); +} + +sub disable_ipc_polling { + my $self = shift; + return unless defined $self->{+IPC_POLLING}; + $self->{+IPC_POLLING} = 0; +} + +sub _ipc_wait { + my $fail = 0; + + if (CAN_FORK) { + while (1) { + my $pid = CORE::wait(); + my $err = $?; + last if $pid == -1; + next unless $err; + $fail++; + $err = $err >> 8; + warn "Process $pid did not exit cleanly (status: $err)\n"; + } + } + + if (USE_THREADS) { + for my $t (threads->list()) { + $t->join; + # In older threads we cannot check if a thread had an error unless + # we control it and its return. + my $err = $t->can('error') ? $t->error : undef; + next unless $err; + my $tid = $t->tid(); + $fail++; + chomp($err); + warn "Thread $tid did not end cleanly: $err\n"; + } + } + + return 0 unless $fail; + return 255; +} + +sub DESTROY { + my $self = shift; + + return unless defined($self->{+_PID}) && $self->{+_PID} == $$; + return unless defined($self->{+_TID}) && $self->{+_TID} == get_tid(); + + shmctl($self->{+IPC_SHM_ID}, IPC::SysV::IPC_RMID(), 0) + if defined $self->{+IPC_SHM_ID}; +} + +sub set_exit { + my $self = shift; + + my $exit = $?; + my $new_exit = $exit; + + if ($INC{'Test/Builder.pm'} && $Test::Builder::VERSION ne $Test2::API::VERSION) { + print STDERR <<" EOT"; + +******************************************************************************** +* * +* Test::Builder -- Test2::API version mismatch detected * +* * +******************************************************************************** + Test2::API Version: $Test2::API::VERSION +Test::Builder Version: $Test::Builder::VERSION + +This is not a supported configuration, you will have problems. + + EOT + } + + for my $ctx (values %{$self->{+CONTEXTS}}) { + next unless $ctx; + + next if $ctx->_aborted && ${$ctx->_aborted}; + + # Only worry about contexts in this PID + my $trace = $ctx->trace || next; + next unless $trace->pid && $trace->pid == $$; + + # Do not worry about contexts that have no hub + my $hub = $ctx->hub || next; + + # Do not worry if the state came to a sudden end. + next if $hub->bailed_out; + next if defined $hub->skip_reason; + + # now we worry + $trace->alert("context object was never released! This means a testing tool is behaving very badly"); + + $exit = 255; + $new_exit = 255; + } + + if (!defined($self->{+_PID}) or !defined($self->{+_TID}) or $self->{+_PID} != $$ or $self->{+_TID} != get_tid()) { + $? = $exit; + return; + } + + my @hubs = $self->{+STACK} ? $self->{+STACK}->all : (); + + if (@hubs and $self->{+IPC} and !$self->{+NO_WAIT}) { + local $?; + my %seen; + for my $hub (reverse @hubs) { + my $ipc = $hub->ipc or next; + next if $seen{$ipc}++; + $ipc->waiting(); + } + + my $ipc_exit = _ipc_wait(); + $new_exit ||= $ipc_exit; + } + + # None of this is necessary if we never got a root hub + if(my $root = shift @hubs) { + my $trace = Test2::Util::Trace->new( + frame => [__PACKAGE__, __FILE__, 0, __PACKAGE__ . '::END'], + detail => __PACKAGE__ . ' END Block finalization', + ); + my $ctx = Test2::API::Context->new( + trace => $trace, + hub => $root, + ); + + if (@hubs) { + $ctx->diag("Test ended with extra hubs on the stack!"); + $new_exit = 255; + } + + unless ($root->no_ending) { + local $?; + $root->finalize($trace) unless $root->ended; + $_->($ctx, $exit, \$new_exit) for @{$self->{+EXIT_CALLBACKS}}; + $new_exit ||= $root->failed; + $new_exit ||= 255 unless $root->is_passing; + } + } + + $new_exit = 255 if $new_exit > 255; + + if ($new_exit && eval { require Test2::API::Breakage; 1 }) { + my @warn = Test2::API::Breakage->report(); + + if (@warn) { + print STDERR "\nYou have loaded versions of test modules known to have problems with Test2.\nThis could explain some test failures.\n"; + print STDERR "$_\n" for @warn; + print STDERR "\n"; + } + } + + $? = $new_exit; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::API::Instance - Object used by Test2::API under the hood + +=head1 DESCRIPTION + +This object encapsulates the global shared state tracked by +L. A single global instance of this package is stored (and +obscured) by the L package. + +There is no reason to directly use this package. This package is documented for +completeness. This package can change, or go away completely at any time. +Directly using, or monkeypatching this package is not supported in any way +shape or form. + +=head1 SYNOPSIS + + use Test2::API::Instance; + + my $obj = Test2::API::Instance->new; + +=over 4 + +=item $pid = $obj->pid + +PID of this instance. + +=item $obj->tid + +Thread ID of this instance. + +=item $obj->reset() + +Reset the object to defaults. + +=item $obj->load() + +Set the internal state to loaded, and run and stored post-load callbacks. + +=item $bool = $obj->loaded + +Check if the state is set to loaded. + +=item $arrayref = $obj->post_load_callbacks + +Get the post-load callbacks. + +=item $obj->add_post_load_callback(sub { ... }) + +Add a post-load callback. If C has already been called then the callback will +be immediately executed. If C has not been called then the callback will be +stored and executed later when C is called. + +=item $hashref = $obj->contexts() + +Get a hashref of all active contexts keyed by hub id. + +=item $arrayref = $obj->context_acquire_callbacks + +Get all context acquire callbacks. + +=item $arrayref = $obj->context_init_callbacks + +Get all context init callbacks. + +=item $arrayref = $obj->context_release_callbacks + +Get all context release callbacks. + +=item $obj->add_context_init_callback(sub { ... }) + +Add a context init callback. Subs are called every time a context is created. Subs +get the newly created context as their only argument. + +=item $obj->add_context_release_callback(sub { ... }) + +Add a context release callback. Subs are called every time a context is released. Subs +get the released context as their only argument. These callbacks should not +call release on the context. + +=item $obj->set_exit() + +This is intended to be called in an C block. This will look at +test state and set $?. This will also call any end callbacks, and wait on child +processes/threads. + +=item $obj->ipc_enable_shm() + +Turn on SHM for IPC (if possible) + +=item $shm_id = $obj->ipc_shm_id() + +If SHM is enabled for IPC this will be the shm_id for it. + +=item $shm_size = $obj->ipc_shm_size() + +If SHM is enabled for IPC this will be the size of it. + +=item $shm_last_val = $obj->ipc_shm_last() + +If SHM is enabled for IPC this will return the last SHM value seen. + +=item $obj->set_ipc_pending($val) + +use the IPC SHM to tell other processes and threads there is a pending event. +C<$val> should be a unique value no other thread/process will generate. + +B This will also make the current process see a pending event. It does +not set C, this is important because doing so could hide a +previous change. + +=item $pending = $obj->get_ipc_pending() + +This returns -1 if SHM is not enabled for IPC. + +This returns 0 if the SHM value matches the last known value, which means there +are no pending events. + +This returns 1 if the SHM value has changed, which means there are probably +pending events. + +When 1 is returned this will set C<< $obj->ipc_shm_last() >>. + +=item $drivers = $obj->ipc_drivers + +Get the list of IPC drivers. + +=item $obj->add_ipc_driver($DRIVER_CLASS) + +Add an IPC driver to the list. The most recently added IPC driver will become +the global one during initialization. If a driver is added after initialization +has occurred a warning will be generated: + + "IPC driver $driver loaded too late to be used as the global ipc driver" + +=item $bool = $obj->ipc_polling + +Check if polling is enabled. + +=item $obj->enable_ipc_polling + +Turn on polling. This will cull events from other processes and threads every +time a context is created. + +=item $obj->disable_ipc_polling + +Turn off IPC polling. + +=item $bool = $obj->no_wait + +=item $bool = $obj->set_no_wait($bool) + +Get/Set no_wait. This option is used to turn off process/thread waiting at exit. + +=item $arrayref = $obj->exit_callbacks + +Get the exit callbacks. + +=item $obj->add_exit_callback(sub { ... }) + +Add an exit callback. This callback will be called by C. + +=item $bool = $obj->finalized + +Check if the object is finalized. Finalization happens when either C, +C, or C are called on the object. Once finalization happens +these fields are considered unchangeable (not enforced here, enforced by +L). + +=item $ipc = $obj->ipc + +Get the one true IPC instance. + +=item $stack = $obj->stack + +Get the one true hub stack. + +=item $formatter = $obj->formatter + +Get the global formatter. By default this is the C<'Test2::Formatter::TAP'> +package. This could be any package that implements the C method. This +can also be an instantiated object. + +=item $bool = $obj->formatter_set() + +Check if a formatter has been set. + +=item $obj->add_formatter($class) + +=item $obj->add_formatter($obj) + +Add a formatter. The most recently added formatter will become the global one +during initialization. If a formatter is added after initialization has occurred +a warning will be generated: + + "Formatter $formatter loaded too late to be used as the global formatter" + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/API/Stack.pm b/Master/tlpkg/tlperl/lib/Test2/API/Stack.pm new file mode 100755 index 00000000000..534cd78d1ba --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/API/Stack.pm @@ -0,0 +1,220 @@ +package Test2::API::Stack; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +use Test2::Hub(); + +use Carp qw/confess/; + +sub new { + my $class = shift; + return bless [], $class; +} + +sub new_hub { + my $self = shift; + my %params = @_; + + my $class = delete $params{class} || 'Test2::Hub'; + + my $hub = $class->new(%params); + + if (@$self) { + $hub->inherit($self->[-1], %params); + } + else { + require Test2::API; + $hub->format(Test2::API::test2_formatter()->new) + unless $hub->format || exists($params{formatter}); + + my $ipc = Test2::API::test2_ipc(); + if ($ipc && !$hub->ipc && !exists($params{ipc})) { + $hub->set_ipc($ipc); + $ipc->add_hub($hub->hid); + } + } + + push @$self => $hub; + + $hub; +} + +sub top { + my $self = shift; + return $self->new_hub unless @$self; + return $self->[-1]; +} + +sub peek { + my $self = shift; + return @$self ? $self->[-1] : undef; +} + +sub cull { + my $self = shift; + $_->cull for reverse @$self; +} + +sub all { + my $self = shift; + return @$self; +} + +sub clear { + my $self = shift; + @$self = (); +} + +# Do these last without keywords in order to prevent them from getting used +# when we want the real push/pop. + +{ + no warnings 'once'; + + *push = sub { + my $self = shift; + my ($hub) = @_; + $hub->inherit($self->[-1]) if @$self; + push @$self => $hub; + }; + + *pop = sub { + my $self = shift; + my ($hub) = @_; + confess "No hubs on the stack" + unless @$self; + confess "You cannot pop the root hub" + if 1 == @$self; + confess "Hub stack mismatch, attempted to pop incorrect hub" + unless $self->[-1] == $hub; + pop @$self; + }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::API::Stack - Object to manage a stack of L +instances. + +=head1 ***INTERNALS NOTE*** + +B The public +methods provided will not change in backwards incompatible ways, but the +underlying implementation details might. B + +=head1 DESCRIPTION + +This module is used to represent and manage a stack of L +objects. Hubs are usually in a stack so that you can push a new hub into place +that can intercept and handle events differently than the primary hub. + +=head1 SYNOPSIS + + my $stack = Test2::API::Stack->new; + my $hub = $stack->top; + +=head1 METHODS + +=over 4 + +=item $stack = Test2::API::Stack->new() + +This will create a new empty stack instance. All arguments are ignored. + +=item $hub = $stack->new_hub() + +=item $hub = $stack->new_hub(%params) + +=item $hub = $stack->new_hub(%params, class => $class) + +This will generate a new hub and push it to the top of the stack. Optionally +you can provide arguments that will be passed into the constructor for the +L object. + +If you specify the C<< 'class' => $class >> argument, the new hub will be an +instance of the specified class. + +Unless your parameters specify C<'formatter'> or C<'ipc'> arguments, the +formatter and IPC instance will be inherited from the current top hub. You can +set the parameters to C to avoid having a formatter or IPC instance. + +If there is no top hub, and you do not ask to leave IPC and formatter undef, +then a new formatter will be created, and the IPC instance from +L will be used. + +=item $hub = $stack->top() + +This will return the top hub from the stack. If there is no top hub yet this +will create it. + +=item $hub = $stack->peek() + +This will return the top hub from the stack. If there is no top hub yet this +will return undef. + +=item $stack->cull + +This will call C<< $hub->cull >> on all hubs in the stack. + +=item @hubs = $stack->all + +This will return all the hubs in the stack as a list. + +=item $stack->clear + +This will completely remove all hubs from the stack. Normally you do not want +to do this, but there are a few valid reasons for it. + +=item $stack->push($hub) + +This will push the new hub onto the stack. + +=item $stack->pop($hub) + +This will pop a hub from the stack, if the hub at the top of the stack does not +match the hub you expect (passed in as an argument) it will throw an exception. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Event.pm b/Master/tlpkg/tlperl/lib/Test2/Event.pm new file mode 100755 index 00000000000..a59a366081d --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Event.pm @@ -0,0 +1,254 @@ +package Test2::Event; +use strict; +use warnings; + +our $VERSION = '1.302073'; + +use Test2::Util::HashBase qw/trace nested in_subtest subtest_id/; +use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; +use Test2::Util qw(pkg_to_file); +use Test2::Util::Trace; + +sub causes_fail { 0 } +sub increments_count { 0 } +sub diagnostics { 0 } +sub no_display { 0 } + +sub callback { } + +sub terminate { () } +sub global { () } +sub sets_plan { () } + +sub summary { ref($_[0]) } + +sub from_json { + my $class = shift; + my %p = @_; + + my $event_pkg = delete $p{__PACKAGE__}; + require(pkg_to_file($event_pkg)); + + if (exists $p{trace}) { + $p{trace} = Test2::Util::Trace->from_json(%{$p{trace}}); + } + + if (exists $p{subevents}) { + my @subevents; + for my $subevent (@{delete $p{subevents} || []}) { + push @subevents, Test2::Event->from_json(%$subevent); + } + $p{subevents} = \@subevents; + } + + return $event_pkg->new(%p); +} + +sub TO_JSON { + my $self = shift; + return {%$self, __PACKAGE__ => ref $self}; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event - Base class for events + +=head1 DESCRIPTION + +Base class for all event objects that get passed through +L. + +=head1 SYNOPSIS + + package Test2::Event::MyEvent; + use strict; + use warnings; + + # This will make our class an event subclass (required) + use base 'Test2::Event'; + + # Add some accessors (optional) + # You are not obligated to use HashBase, you can use any object tool you + # want, or roll your own accessors. + use Test2::Util::HashBase qw/foo bar baz/; + + # Chance to initialize some defaults + sub init { + my $self = shift; + # no other args in @_ + + $self->set_foo('xxx') unless defined $self->foo; + + ... + } + + 1; + +=head1 METHODS + +=over 4 + +=item $trace = $e->trace + +Get a snapshot of the L as it was when this event was +generated + +=item $bool = $e->causes_fail + +Returns true if this event should result in a test failure. In general this +should be false. + +=item $bool = $e->increments_count + +Should be true if this event should result in a test count increment. + +=item $e->callback($hub) + +If your event needs to have extra effects on the L you can override +this method. + +This is called B your event is passed to the formatter. + +=item $call = $e->created + +Get the C details from when the event was generated. This is usually +inside a tools package. This is typically used for debugging. + +=item $num = $e->nested + +If this event is nested inside of other events, this should be the depth of +nesting. (This is mainly for subtests) + +=item $bool = $e->global + +Set this to true if your event is global, that is ALL threads and processes +should see it no matter when or where it is generated. This is not a common +thing to want, it is used by bail-out and skip_all to end testing. + +=item $code = $e->terminate + +This is called B your event has been passed to the formatter. This +should normally return undef, only change this if your event should cause the +test to exit immediately. + +If you want this event to cause the test to exit you should return the exit +code here. Exit code of 0 means exit success, any other integer means exit with +failure. + +This is used by L to exit 0 when the plan is +'skip_all'. This is also used by L to force the test +to exit with a failure. + +This is called after the event has been sent to the formatter in order to +ensure the event is seen and understood. + +=item $todo = $e->todo + +=item $e->set_todo($todo) + +Get/Set the todo reason on the event. Any value other than C makes the +event 'TODO'. + +Not all events make use of this field, but they can all have it set/cleared. + +=item $bool = $e->diag_todo + +=item $e->diag_todo($todo) + +True if this event should be considered 'TODO' for diagnostics purposes. This +essentially means that any message that would go to STDERR will go to STDOUT +instead so that a harness will hide it outside of verbose mode. + +=item $msg = $e->summary + +This is intended to be a human readable summary of the event. This should +ideally only be one line long, but you can use multiple lines if necessary. This +is intended for human consumption. You do not need to make it easy for machines +to understand. + +The default is to simply return the event package name. + +=item ($count, $directive, $reason) = $e->sets_plan() + +Check if this event sets the testing plan. It will return an empty list if it +does not. If it does set the plan it will return a list of 1 to 3 items in +order: Expected Test Count, Test Directive, Reason for directive. + +=item $bool = $e->diagnostics + +True if the event contains diagnostics info. This is useful because a +non-verbose harness may choose to hide events that are not in this category. +Some formatters may choose to send these to STDERR instead of STDOUT to ensure +they are seen. + +=item $bool = $e->no_display + +False by default. This will return true on events that should not be displayed +by formatters. + +=item $id = $e->in_subtest + +If the event is inside a subtest this should have the subtest ID. + +=item $id = $e->subtest_id + +If the event is a final subtest event, this should contain the subtest ID. + +=item $hashref = $e->TO_JSON + +This returns a hashref suitable for passing to the C<< Test2::Event->from_json +>> constructor. It is intended for use with the L family of modules, +which will look for a C method when C is true. + +=item $e = Test2::Event->from_json(%$hashref) + +Given the hash of data returned by C<< $e->TO_JSON >>, this method returns a +new event object of the appropriate subclass. + +=back + +=head1 THIRD PARTY META-DATA + +This object consumes L which provides a consistent +way for you to attach meta-data to instances of this class. This is useful for +tools, plugins, and other extensions. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Event/Bail.pm b/Master/tlpkg/tlperl/lib/Test2/Event/Bail.pm new file mode 100755 index 00000000000..0284aecd00f --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Event/Bail.pm @@ -0,0 +1,102 @@ +package Test2::Event::Bail; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw{reason}; + +sub callback { + my $self = shift; + my ($hub) = @_; + + $hub->set_bailed_out($self); +} + +# Make sure the tests terminate +sub terminate { 255 }; + +sub global { 1 }; + +sub causes_fail { 1 } + +sub summary { + my $self = shift; + return "Bail out! " . $self->{+REASON} + if $self->{+REASON}; + + return "Bail out!"; +} + +sub diagnostics { 1 } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Bail - Bailout! + +=head1 DESCRIPTION + +The bailout event is generated when things go horribly wrong and you need to +halt all testing in the current file. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Bail; + + my $ctx = context(); + my $event = $ctx->bail('Stuff is broken'); + +=head1 METHODS + +Inherits from L. Also defines: + +=over 4 + +=item $reason = $e->reason + +The reason for the bailout. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Event/Diag.pm b/Master/tlpkg/tlperl/lib/Test2/Event/Diag.pm new file mode 100755 index 00000000000..9d2ba88d6e3 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Event/Diag.pm @@ -0,0 +1,83 @@ +package Test2::Event::Diag; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw/message/; + +sub init { + $_[0]->{+MESSAGE} = 'undef' unless defined $_[0]->{+MESSAGE}; +} + +sub summary { $_[0]->{+MESSAGE} } + +sub diagnostics { 1 } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Diag - Diag event type + +=head1 DESCRIPTION + +Diagnostics messages, typically rendered to STDERR. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Diag; + + my $ctx = context(); + my $event = $ctx->diag($message); + +=head1 ACCESSORS + +=over 4 + +=item $diag->message + +The message for the diag. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Event/Encoding.pm b/Master/tlpkg/tlperl/lib/Test2/Event/Encoding.pm new file mode 100755 index 00000000000..52af3f2dc51 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Event/Encoding.pm @@ -0,0 +1,86 @@ +package Test2::Event::Encoding; +use strict; +use warnings; + +our $VERSION = '1.302073'; + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw/encoding/; + +sub init { + my $self = shift; + defined $self->{+ENCODING} or $self->trace->throw("'encoding' is a required attribute"); +} + +sub summary { 'Encoding set to ' . $_[0]->{+ENCODING} } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Encoding - Set the encoding for the output stream + +=head1 DESCRIPTION + +The encoding event is generated when a test file wants to specify the encoding +to be used when formatting its output. This event is intended to be produced +by formatter classes and used for interpreting test names, message contents, +etc. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Encoding; + + my $ctx = context(); + my $event = $ctx->send_event('Encoding', encoding => 'UTF-8'); + +=head1 METHODS + +Inherits from L. Also defines: + +=over 4 + +=item $encoding = $e->encoding + +The encoding being specified. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Event/Exception.pm b/Master/tlpkg/tlperl/lib/Test2/Event/Exception.pm new file mode 100755 index 00000000000..a10ca6756c0 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Event/Exception.pm @@ -0,0 +1,88 @@ +package Test2::Event::Exception; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw{error}; + +sub causes_fail { 1 } + +sub summary { + my $self = shift; + chomp(my $msg = "Exception: " . $self->{+ERROR}); + return $msg; +} + +sub diagnostics { 1 } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Exception - Exception event + +=head1 DESCRIPTION + +An exception event will display to STDERR, and will prevent the overall test +file from passing. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Exception; + + my $ctx = context(); + my $event = $ctx->send_event('Exception', error => 'Stuff is broken'); + +=head1 METHODS + +Inherits from L. Also defines: + +=over 4 + +=item $reason = $e->error + +The reason for the exception. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Event/Generic.pm b/Master/tlpkg/tlperl/lib/Test2/Event/Generic.pm new file mode 100755 index 00000000000..ad00f5a963d --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Event/Generic.pm @@ -0,0 +1,263 @@ +package Test2::Event::Generic; +use strict; +use warnings; + +use Carp qw/croak/; +use Scalar::Util qw/reftype/; + +our $VERSION = '1.302073'; + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase; + +my @FIELDS = qw{ + causes_fail increments_count diagnostics no_display callback terminate + global sets_plan summary +}; +my %DEFAULTS = ( + causes_fail => 0, + increments_count => 0, + diagnostics => 0, + no_display => 0, +); + +sub init { + my $self = shift; + + for my $field (@FIELDS) { + my $val = defined $self->{$field} ? delete $self->{$field} : $DEFAULTS{$field}; + next unless defined $val; + + my $set = "set_$field"; + $self->$set($val); + } +} + +for my $field (@FIELDS) { + no strict 'refs'; + my $stash = \%{__PACKAGE__ . "::"}; + + *$field = sub { exists $_[0]->{$field} ? $_[0]->{$field} : () } + unless defined $stash->{$field} + && defined *{$stash->{$field}}{CODE}; + + *{"set_$field"} = sub { $_[0]->{$field} = $_[1] } + unless defined $stash->{"set_$field"} + && defined *{$stash->{"set_$field"}}{CODE}; +} + +sub summary { + my $self = shift; + return $self->{summary} if defined $self->{summary}; + $self->SUPER::summary(); +} + +sub sets_plan { + my $self = shift; + return unless $self->{sets_plan}; + return @{$self->{sets_plan}}; +} + +sub callback { + my $self = shift; + my $cb = $self->{callback} || return; + $self->$cb(@_); +} + +sub set_global { + my $self = shift; + my ($bool) = @_; + + if(!defined $bool) { + delete $self->{global}; + return undef; + } + + $self->{global} = $bool; +} + +sub set_callback { + my $self = shift; + my ($cb) = @_; + + if(!defined $cb) { + delete $self->{callback}; + return undef; + } + + croak "callback must be a code reference" + unless ref($cb) && reftype($cb) eq 'CODE'; + + $self->{callback} = $cb; +} + +sub set_terminate { + my $self = shift; + my ($exit) = @_; + + if(!defined $exit) { + delete $self->{terminate}; + return undef; + } + + croak "terminate must be a positive integer" + unless $exit =~ m/^\d+$/; + + $self->{terminate} = $exit; +} + +sub set_sets_plan { + my $self = shift; + my ($plan) = @_; + + if(!defined $plan) { + delete $self->{sets_plan}; + return undef; + } + + croak "'sets_plan' must be an array reference" + unless ref($plan) && reftype($plan) eq 'ARRAY'; + + $self->{sets_plan} = $plan; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Generic - Generic event type. + +=head1 DESCRIPTION + +This is a generic event that lets you customize all fields in the event API. +This is useful if you have need for a custom event that does not make sense as +a published reusable event subclass. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + + sub send_custom_fail { + my $ctx = shift; + + $ctx->send_event('Generic', causes_fail => 1, summary => 'The sky is falling'); + + $ctx->release; + } + + send_custom_fail(); + +=head1 METHODS + +=over 4 + +=item $e->callback($hub) + +Call the custom callback if one is set, otherwise this does nothing. + +=item $e->set_callback(sub { ... }) + +Set the custom callback. The custom callback must be a coderef. The first +argument to your callback will be the event itself, the second will be the +L that is using the callback. + +=item $bool = $e->causes_fail + +=item $e->set_causes_fail($bool) + +Get/Set the C attribute. This defaults to C<0>. + +=item $bool = $e->diagnostics + +=item $e->set_diagnostics($bool) + +Get/Set the C attribute. This defaults to C<0>. + +=item $bool_or_undef = $e->global + +=item @bool_or_empty = $e->global + +=item $e->set_global($bool_or_undef) + +Get/Set the C attribute. This defaults to an empty list which is +undef in scalar context. + +=item $bool = $e->increments_count + +=item $e->set_increments_count($bool) + +Get/Set the C attribute. This defaults to C<0>. + +=item $bool = $e->no_display + +=item $e->set_no_display($bool) + +Get/Set the C attribute. This defaults to C<0>. + +=item @plan = $e->sets_plan + +Get the plan if this event sets one. The plan is a list of up to 3 items: +C<($count, $directive, $reason)>. C<$count> must be defined, the others may be +undef, or may not exist at all. + +=item $e->set_sets_plan(\@plan) + +Set the plan. You must pass in an arrayref with up to 3 elements. + +=item $summary = $e->summary + +=item $e->set_summary($summary_or_undef) + +Get/Set the summary. This will default to the event package +C<'Test2::Event::Generic'>. You can set it to any value. Setting this to +C will reset it to the default. + +=item $int_or_undef = $e->terminate + +=item @int_or_empty = $e->terminate + +=item $e->set_terminate($int_or_undef) + +This will get/set the C attribute. This defaults to undef in scalar +context, or an empty list in list context. Setting this to undef will clear it +completely. This must be set to a positive integer (0 or larger). + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Event/Info.pm b/Master/tlpkg/tlperl/lib/Test2/Event/Info.pm new file mode 100755 index 00000000000..51c4bbcd317 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Event/Info.pm @@ -0,0 +1,127 @@ +package Test2::Event::Info; +use strict; +use warnings; + +use Scalar::Util qw/blessed/; + +our $VERSION = '1.302073'; + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw/diagnostics renderer/; + +sub init { + my $self = shift; + + my $r = $self->{+RENDERER} or $self->trace->throw("'renderer' is a required attribute"); + + return if ref($r) eq 'CODE'; + return if blessed($r) && $r->can('render'); + + $self->trace->throw("renderer '$r' is not a valid renderer, must be a coderef or an object implementing the 'render()' method"); +} + +sub render { + my $self = shift; + my ($fmt) = @_; + + $fmt ||= 'text'; + + my $r = $self->{+RENDERER}; + + return $r->($fmt) if ref($r) eq 'CODE'; + return $r->render($fmt); +} + +sub summary { $_[0]->render($_[1] || 'text') } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Info - Info event base class + +=head1 DESCRIPTION + +Successor for note and diag events. This event base class supports multiple +formats. This event makes it possible to send additional information such as +color and highlighting to the harness. + +=head1 SYNOPSIS + + use Test2::API::Context qw/context/; + + $ctx->info($obj, diagnostics => $bool); + +=head1 FORMATS + +Format will be passed in to C and C as a string. Any +string is considered valid, if your event does not recognize the format it +should fallback to 'text'. + +=over 4 + +=item 'text' + +Plain and ordinary text. + +=item 'ansi' + +Text that may include ansi sequences such as colors. + +=item 'html' + +HTML formatted text. + +=back + +=head1 ACCESSORS + +=over 4 + +=item $bool = $info->diagnostics() + +=item $info->set_diagnostics($bool) + +True if this info is essential for diagnostics. The implication is that +diagnostics will got to STDERR while everything else goes to STDOUT, but that +is formatter/harness specific. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Event/Note.pm b/Master/tlpkg/tlperl/lib/Test2/Event/Note.pm new file mode 100755 index 00000000000..b9a2ded1e13 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Event/Note.pm @@ -0,0 +1,81 @@ +package Test2::Event::Note; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw/message/; + +sub init { + $_[0]->{+MESSAGE} = 'undef' unless defined $_[0]->{+MESSAGE}; +} + +sub summary { $_[0]->{+MESSAGE} } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Note - Note event type + +=head1 DESCRIPTION + +Notes, typically rendered to STDOUT. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Note; + + my $ctx = context(); + my $event = $ctx->Note($message); + +=head1 ACCESSORS + +=over 4 + +=item $note->message + +The message for the note. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Event/Ok.pm b/Master/tlpkg/tlperl/lib/Test2/Event/Ok.pm new file mode 100755 index 00000000000..456d6bbcf3c --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Event/Ok.pm @@ -0,0 +1,140 @@ +package Test2::Event::Ok; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw{ + pass effective_pass name todo +}; + +sub init { + my $self = shift; + + # Do not store objects here, only true or false + $self->{+PASS} = $self->{+PASS} ? 1 : 0; + $self->{+EFFECTIVE_PASS} = $self->{+PASS} || (defined($self->{+TODO}) ? 1 : 0); +} + +{ + no warnings 'redefine'; + sub set_todo { + my $self = shift; + my ($todo) = @_; + $self->{+TODO} = $todo; + $self->{+EFFECTIVE_PASS} = defined($todo) ? 1 : $self->{+PASS}; + } +} + +sub increments_count { 1 }; + +sub causes_fail { !$_[0]->{+EFFECTIVE_PASS} } + +sub summary { + my $self = shift; + + my $name = $self->{+NAME} || "Nameless Assertion"; + + my $todo = $self->{+TODO}; + if ($todo) { + $name .= " (TODO: $todo)"; + } + elsif (defined $todo) { + $name .= " (TODO)" + } + + return $name; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Ok - Ok event type + +=head1 DESCRIPTION + +Ok events are generated whenever you run a test that produces a result. +Examples are C, and C. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Ok; + + my $ctx = context(); + my $event = $ctx->ok($bool, $name, \@diag); + +or: + + my $ctx = context(); + my $event = $ctx->send_event( + 'Ok', + pass => $bool, + name => $name, + ); + +=head1 ACCESSORS + +=over 4 + +=item $rb = $e->pass + +The original true/false value of whatever was passed into the event (but +reduced down to 1 or 0). + +=item $name = $e->name + +Name of the test. + +=item $b = $e->effective_pass + +This is the true/false value of the test after TODO and similar modifiers are +taken into account. + +=item $b = $e->allow_bad_name + +This relaxes the test name checks such that they allow characters that can +confuse a TAP parser. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Event/Plan.pm b/Master/tlpkg/tlperl/lib/Test2/Event/Plan.pm new file mode 100755 index 00000000000..94b3030c349 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Event/Plan.pm @@ -0,0 +1,160 @@ +package Test2::Event::Plan; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw{max directive reason}; + +use Carp qw/confess/; + +my %ALLOWED = ( + 'SKIP' => 1, + 'NO PLAN' => 1, +); + +sub init { + if ($_[0]->{+DIRECTIVE}) { + $_[0]->{+DIRECTIVE} = 'SKIP' if $_[0]->{+DIRECTIVE} eq 'skip_all'; + $_[0]->{+DIRECTIVE} = 'NO PLAN' if $_[0]->{+DIRECTIVE} eq 'no_plan'; + + confess "'" . $_[0]->{+DIRECTIVE} . "' is not a valid plan directive" + unless $ALLOWED{$_[0]->{+DIRECTIVE}}; + } + else { + confess "Cannot have a reason without a directive!" + if defined $_[0]->{+REASON}; + + confess "No number of tests specified" + unless defined $_[0]->{+MAX}; + + confess "Plan test count '" . $_[0]->{+MAX} . "' does not appear to be a valid positive integer" + unless $_[0]->{+MAX} =~ m/^\d+$/; + + $_[0]->{+DIRECTIVE} = ''; + } +} + +sub sets_plan { + my $self = shift; + return ( + $self->{+MAX}, + $self->{+DIRECTIVE}, + $self->{+REASON}, + ); +} + +sub callback { + my $self = shift; + my ($hub) = @_; + + $hub->plan($self->{+DIRECTIVE} || $self->{+MAX}); + + return unless $self->{+DIRECTIVE}; + + $hub->set_skip_reason($self->{+REASON} || 1) if $self->{+DIRECTIVE} eq 'SKIP'; +} + +sub terminate { + my $self = shift; + # On skip_all we want to terminate the hub + return 0 if $self->{+DIRECTIVE} && $self->{+DIRECTIVE} eq 'SKIP'; + return undef; +} + +sub summary { + my $self = shift; + my $max = $self->{+MAX}; + my $directive = $self->{+DIRECTIVE}; + my $reason = $self->{+REASON}; + + return "Plan is $max assertions" + if $max || !$directive; + + return "Plan is '$directive', $reason" + if $reason; + + return "Plan is '$directive'"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Plan - The event of a plan + +=head1 DESCRIPTION + +Plan events are fired off whenever a plan is declared, done testing is called, +or a subtext completes. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Plan; + + my $ctx = context(); + + # Plan for 10 tests to run + my $event = $ctx->plan(10); + + # Plan to skip all tests (will exit 0) + $ctx->plan(0, skip_all => "These tests need to be skipped"); + +=head1 ACCESSORS + +=over 4 + +=item $num = $plan->max + +Get the number of expected tests + +=item $dir = $plan->directive + +Get the directive (such as TODO, skip_all, or no_plan). + +=item $reason = $plan->reason + +Get the reason for the directive. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Event/Skip.pm b/Master/tlpkg/tlperl/lib/Test2/Event/Skip.pm new file mode 100755 index 00000000000..7cca06165b9 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Event/Skip.pm @@ -0,0 +1,108 @@ +package Test2::Event::Skip; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) } +use Test2::Util::HashBase qw{reason}; + +sub init { + my $self = shift; + $self->SUPER::init; + $self->{+EFFECTIVE_PASS} = 1; +} + +sub causes_fail { 0 } + +sub summary { + my $self = shift; + my $out = $self->SUPER::summary(@_); + + if (my $reason = $self->reason) { + $out .= " (SKIP: $reason)"; + } + else { + $out .= " (SKIP)"; + } + + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Skip - Skip event type + +=head1 DESCRIPTION + +Skip events bump test counts just like L events, but +they can never fail. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Skip; + + my $ctx = context(); + my $event = $ctx->skip($name, $reason); + +or: + + my $ctx = context(); + my $event = $ctx->send_event( + 'Skip', + name => $name, + reason => $reason, + ); + +=head1 ACCESSORS + +=over 4 + +=item $reason = $e->reason + +The original true/false value of whatever was passed into the event (but +reduced down to 1 or 0). + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Event/Subtest.pm b/Master/tlpkg/tlperl/lib/Test2/Event/Subtest.pm new file mode 100755 index 00000000000..2b3c773bf67 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Event/Subtest.pm @@ -0,0 +1,131 @@ +package Test2::Event::Subtest; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) } +use Test2::Util::HashBase qw{subevents buffered subtest_id}; + +sub init { + my $self = shift; + $self->SUPER::init(); + $self->{+SUBEVENTS} ||= []; + if ($self->{+EFFECTIVE_PASS}) { + $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}; + } +} + +{ + no warnings 'redefine'; + + sub set_subevents { + my $self = shift; + my @subevents = @_; + + if ($self->{+EFFECTIVE_PASS}) { + $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @subevents; + } + + $self->{+SUBEVENTS} = \@subevents; + } + + sub set_effective_pass { + my $self = shift; + my ($pass) = @_; + + if ($pass) { + $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}; + } + elsif ($self->{+EFFECTIVE_PASS} && !$pass) { + for my $s (grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}) { + $_->set_effective_pass(0) unless $s->can('todo') && defined $s->todo; + } + } + + $self->{+EFFECTIVE_PASS} = $pass; + } +} + +sub summary { + my $self = shift; + + my $name = $self->{+NAME} || "Nameless Subtest"; + + my $todo = $self->{+TODO}; + if ($todo) { + $name .= " (TODO: $todo)"; + } + elsif (defined $todo) { + $name .= " (TODO)" + } + + return $name; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Subtest - Event for subtest types + +=head1 DESCRIPTION + +This class represents a subtest. This class is a subclass of +L. + +=head1 ACCESSORS + +This class inherits from L. + +=over 4 + +=item $arrayref = $e->subevents + +Returns the arrayref containing all the events from the subtest + +=item $bool = $e->buffered + +True if the subtest is buffered, that is all subevents render at once. If this +is false it means all subevents render as they are produced. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Event/TAP/Version.pm b/Master/tlpkg/tlperl/lib/Test2/Event/TAP/Version.pm new file mode 100755 index 00000000000..b96a25adde4 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Event/TAP/Version.pm @@ -0,0 +1,83 @@ +package Test2::Event::TAP::Version; +use strict; +use warnings; + +our $VERSION = '1.302073'; + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw/version/; + +sub init { + my $self = shift; + defined $self->{+VERSION} or $self->trace->throw("'version' is a required attribute"); +} + +sub summary { 'TAP version ' . $_[0]->{+VERSION} } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::TAP::Version - Event for TAP version. + +=head1 DESCRIPTION + +This event is used if a TAP formatter wishes to set a version. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + use Test2::Event::Encoding; + + my $ctx = context(); + my $event = $ctx->send_event('TAP::Version', version => 42); + +=head1 METHODS + +Inherits from L. Also defines: + +=over 4 + +=item $version = $e->version + +The TAP version being parsed. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Event/Waiting.pm b/Master/tlpkg/tlperl/lib/Test2/Event/Waiting.pm new file mode 100755 index 00000000000..fa87c6e8dd7 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Event/Waiting.pm @@ -0,0 +1,61 @@ +package Test2::Event::Waiting; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } + +sub global { 1 }; + +sub summary { "IPC is waiting for children to finish..." } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Waiting - Tell all procs/threads it is time to be done + +=head1 DESCRIPTION + +This event has no data of its own. This event is sent out by the IPC system +when the main process/thread is ready to end. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Formatter.pm b/Master/tlpkg/tlperl/lib/Test2/Formatter.pm new file mode 100755 index 00000000000..945d545dd65 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Formatter.pm @@ -0,0 +1,128 @@ +package Test2::Formatter; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +my %ADDED; +sub import { + my $class = shift; + return if $class eq __PACKAGE__; + return if $ADDED{$class}++; + require Test2::API; + Test2::API::test2_formatter_add($class); +} + +sub hide_buffered { 1 } + +sub terminate { } + +sub finalize { } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Formatter - Namespace for formatters. + +=head1 DESCRIPTION + +This is the namespace for formatters. This is an empty package. + +=head1 CREATING FORMATTERS + +A formatter is any package or object with a C method. + + package Test2::Formatter::Foo; + use strict; + use warnings; + + sub write { + my $self_or_class = shift; + my ($event, $assert_num) = @_; + ... + } + + sub hide_buffered { 1 } + + sub terminate { } + + sub finalize { } + + 1; + +The C method is a method, so it either gets a class or instance. The two +arguments are the C<$event> object it should record, and the C<$assert_num> +which is the number of the current assertion (ok), or the last assertion if +this even is not itself an assertion. The assertion number may be any integer 0 +or greater, and may be undefined in some cases. + +The C method must return a boolean. This is used to tell +buffered subtests whether or not to send it events as they are being buffered. +See L for more information. + +The C and C methods are optional methods called that you +can implement if the format you're generating needs to handle these cases, for +example if you are generating XML and need close open tags. + +The C method is called when an event's C method returns +true, for example when a L has a C<'skip_all'> plan, or +when a L event is sent. The C method is passed +a single argument, the L object which triggered the terminate. + +The C method is always the last thing called on the formatter, I<< +except when C is called for a Bail event >>. It is passed the +following arguments: + +=over 4 + +=item * The number of tests that were planned + +=item * The number of tests actually seen + +=item * The number of tests which failed + +=item * A boolean indicating whether or not the test suite passed + +=item * A boolean indicating whether or not this call is for a subtest + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Formatter/TAP.pm b/Master/tlpkg/tlperl/lib/Test2/Formatter/TAP.pm new file mode 100755 index 00000000000..680095cfede --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Formatter/TAP.pm @@ -0,0 +1,538 @@ +package Test2::Formatter::TAP; +use strict; +use warnings; +require PerlIO; + +our $VERSION = '1.302073'; + +use Test2::Util::HashBase qw{ + no_numbers handles _encoding +}; + +sub OUT_STD() { 0 } +sub OUT_ERR() { 1 } + +use Carp qw/croak/; + +BEGIN { require Test2::Formatter; our @ISA = qw(Test2::Formatter) } + +my %CONVERTERS = ( + 'Test2::Event::Ok' => 'event_ok', + 'Test2::Event::Skip' => 'event_skip', + 'Test2::Event::Note' => 'event_note', + 'Test2::Event::Diag' => 'event_diag', + 'Test2::Event::Bail' => 'event_bail', + 'Test2::Event::Exception' => 'event_exception', + 'Test2::Event::Subtest' => 'event_subtest', + 'Test2::Event::Plan' => 'event_plan', + 'Test2::Event::TAP::Version' => 'event_version', +); + +# Initial list of converters are safe for direct hash access cause we control them. +my %SAFE_TO_ACCESS_HASH = %CONVERTERS; + +sub register_event { + my $class = shift; + my ($type, $convert) = @_; + croak "Event type is a required argument" unless $type; + croak "Event type '$type' already registered" if $CONVERTERS{$type}; + croak "The second argument to register_event() must be a code reference or method name" + unless $convert && (ref($convert) eq 'CODE' || $class->can($convert)); + $CONVERTERS{$type} = $convert; +} + +_autoflush(\*STDOUT); +_autoflush(\*STDERR); + +sub init { + my $self = shift; + + $self->{+HANDLES} ||= $self->_open_handles; + if(my $enc = delete $self->{encoding}) { + $self->encoding($enc); + } +} + +sub hide_buffered { 1 } + +sub encoding { + my $self = shift; + + if (@_) { + my ($enc) = @_; + my $handles = $self->{+HANDLES}; + + # https://rt.perl.org/Public/Bug/Display.html?id=31923 + # If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in + # order to avoid the thread segfault. + if ($enc =~ m/^utf-?8$/i) { + binmode($_, ":utf8") for @$handles; + } + else { + binmode($_, ":encoding($enc)") for @$handles; + } + $self->{+_ENCODING} = $enc; + } + + return $self->{+_ENCODING}; +} + +if ($^C) { + no warnings 'redefine'; + *write = sub {}; +} +sub write { + my ($self, $e, $num) = @_; + + my $type = ref($e); + + my $converter = $CONVERTERS{$type} || 'event_other'; + my @tap = $self->$converter($e, $self->{+NO_NUMBERS} ? undef : $num) or return; + + my $handles = $self->{+HANDLES}; + my $nesting = ($SAFE_TO_ACCESS_HASH{$type} ? $e->{nested} : $e->nested) || 0; + my $indent = ' ' x $nesting; + + # Local is expensive! Only do it if we really need to. + local($\, $,) = (undef, '') if $\ || $,; + for my $set (@tap) { + no warnings 'uninitialized'; + my ($hid, $msg) = @$set; + next unless $msg; + my $io = $handles->[$hid] or next; + + $msg =~ s/^/$indent/mg if $nesting; + print $io $msg; + } +} + +sub _open_handles { + my $self = shift; + + my %seen; + open(my $out, '>&', STDOUT) or die "Can't dup STDOUT: $!"; + binmode($out, join(":", "", "raw", grep { $_ ne 'unix' and !$seen{$_}++ } PerlIO::get_layers(STDOUT))); + + %seen = (); + open(my $err, '>&', STDERR) or die "Can't dup STDERR: $!"; + binmode($err, join(":", "", "raw", grep { $_ ne 'unix' and !$seen{$_}++ } PerlIO::get_layers(STDERR))); + + _autoflush($out); + _autoflush($err); + + return [$out, $err]; +} + +sub _autoflush { + my($fh) = pop; + my $old_fh = select $fh; + $| = 1; + select $old_fh; +} + +sub event_tap { + my $self = shift; + my ($e, $num) = @_; + + my $converter = $CONVERTERS{ref($e)} or return; + + $num = undef if $self->{+NO_NUMBERS}; + + return $self->$converter($e, $num); +} + +sub event_ok { + my $self = shift; + my ($e, $num) = @_; + + # We use direct hash access for performance. OK events are so common we + # need this to be fast. + my ($name, $todo) = @{$e}{qw/name todo/}; + my $in_todo = defined($todo); + + my $out = ""; + $out .= "not " unless $e->{pass}; + $out .= "ok"; + $out .= " $num" if defined($num); + + # The regex form is ~250ms, the index form is ~50ms + my @extra; + defined($name) && ( + (index($name, "\n") != -1 && (($name, @extra) = split(/\n\r?/, $name, -1))), + ((index($name, "#" ) != -1 || substr($name, -1) eq '\\') && (($name =~ s|\\|\\\\|g), ($name =~ s|#|\\#|g))) + ); + + my $space = @extra ? ' ' x (length($out) + 2) : ''; + + $out .= " - $name" if defined $name; + $out .= " # TODO" if $in_todo; + $out .= " $todo" if defined($todo) && length($todo); + + # The primary line of TAP, if the test passed this is all we need. + return([OUT_STD, "$out\n"]) unless @extra; + + return $self->event_ok_multiline($out, $space, @extra); +} + +sub event_ok_multiline { + my $self = shift; + my ($out, $space, @extra) = @_; + + return( + [OUT_STD, "$out\n"], + map {[OUT_STD, "#${space}$_\n"]} @extra, + ); +} + +sub event_skip { + my $self = shift; + my ($e, $num) = @_; + + my $name = $e->name; + my $reason = $e->reason; + my $todo = $e->todo; + + my $out = ""; + $out .= "not " unless $e->{pass}; + $out .= "ok"; + $out .= " $num" if defined $num; + $out .= " - $name" if $name; + if (defined($todo)) { + $out .= " # TODO & SKIP" + } + else { + $out .= " # skip"; + } + $out .= " $reason" if defined($reason) && length($reason); + + return([OUT_STD, "$out\n"]); +} + +sub event_note { + my $self = shift; + my ($e, $num) = @_; + + chomp(my $msg = $e->message); + $msg =~ s/^/# /; + $msg =~ s/\n/\n# /g; + + return [OUT_STD, "$msg\n"]; +} + +sub event_diag { + my $self = shift; + my ($e, $num) = @_; + + chomp(my $msg = $e->message); + $msg =~ s/^/# /; + $msg =~ s/\n/\n# /g; + + return [OUT_ERR, "$msg\n"]; +} + +sub event_bail { + my $self = shift; + my ($e, $num) = @_; + + return if $e->nested; + + return [ + OUT_STD, + "Bail out! " . $e->reason . "\n", + ]; +} + +sub event_exception { + my $self = shift; + my ($e, $num) = @_; + return [ OUT_ERR, $e->error ]; +} + +sub event_subtest { + my $self = shift; + my ($e, $num) = @_; + + # A 'subtest' is a subclass of 'ok'. Let the code that renders 'ok' render + # this event. + my ($ok, @diag) = $self->event_ok($e, $num); + + # If the subtest is not buffered then the sub-events have already been + # rendered, we can go ahead and return. + return ($ok, @diag) unless $e->buffered; + + # In a verbose harness we indent the diagnostics from the 'Ok' event since + # they will appear inside the subtest braces. This helps readability. In a + # non-verbose harness we do not do this because it is less readable. + if ($ENV{HARNESS_IS_VERBOSE}) { + # index 0 is the filehandle, index 1 is the message we want to indent. + $_->[1] =~ s/^(.*\S.*)$/ $1/mg for @diag; + } + + # Add the trailing ' {' to the 'ok' line of TAP output. + $ok->[1] =~ s/\n/ {\n/; + + # Render the sub-events, we use our own counter for these. + my $count = 0; + my @subs = map { + # Bump the count for any event that should bump it. + $count++ if $_->increments_count; + + # This indents all output lines generated for the sub-events. + # index 0 is the filehandle, index 1 is the message we want to indent. + map { $_->[1] =~ s/^(.*\S.*)$/ $1/mg; $_ } $self->event_tap($_, $count); + } @{$e->subevents}; + + return ( + $ok, # opening ok - name { + @diag, # diagnostics if the subtest failed + @subs, # All the inner-event lines + [OUT_STD(), "}\n"], # } (closing brace) + ); +} + +sub event_plan { + my $self = shift; + my ($e, $num) = @_; + + my $directive = $e->directive; + return if $directive && $directive eq 'NO PLAN'; + + my $reason = $e->reason; + $reason =~ s/\n/\n# /g if $reason; + + my $plan = "1.." . $e->max; + if ($directive) { + $plan .= " # $directive"; + $plan .= " $reason" if defined $reason; + } + + return [OUT_STD, "$plan\n"]; +} + +sub event_version { + my $self = shift; + my ($e, $num) = @_; + + my $version = $e->version; + + return [OUT_STD, "TAP version $version\n"]; +} + +sub event_other { + my $self = shift; + my ($e, $num) = @_; + return if $e->no_display; + + my @out; + + if (my ($max, $directive, $reason) = $e->sets_plan) { + my $plan = "1..$max"; + $plan .= " # $directive" if $directive; + $plan .= " $reason" if defined $reason; + push @out => [OUT_STD, "$plan\n"]; + } + + if ($e->increments_count) { + my $ok = ""; + $ok .= "not " if $e->causes_fail; + $ok .= "ok"; + $ok .= " $num" if defined($num); + $ok .= " - " . $e->summary if $e->summary; + + push @out => [OUT_STD, "$ok\n"]; + } + else { # Comment + my $handle = ($e->causes_fail || $e->diagnostics) ? OUT_ERR : OUT_STD; + my $summary = $e->summary || ref($e); + chomp($summary); + $summary =~ s/^/# /smg; + push @out => [$handle, "$summary\n"]; + } + + return @out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Formatter::TAP - Standard TAP formatter + +=head1 DESCRIPTION + +This is what takes events and turns them into TAP. + +=head1 SYNOPSIS + + use Test2::Formatter::TAP; + my $tap = Test2::Formatter::TAP->new(); + + # Switch to utf8 + $tap->encoding('utf8'); + + $tap->write($event, $number); # Output an event + +=head1 METHODS + +=over 4 + +=item $bool = $tap->no_numbers + +=item $tap->set_no_numbers($bool) + +Use to turn numbers on and off. + +=item $arrayref = $tap->handles + +=item $tap->set_handles(\@handles); + +Can be used to get/set the filehandles. Indexes are identified by the +C and C constants. + +=item $encoding = $tap->encoding + +=item $tap->encoding($encoding) + +Get or set the encoding. By default no encoding is set, the original settings +of STDOUT and STDERR are used. + +This directly modifies the stored filehandles, it does not create new ones. + +=item $tap->write($e, $num) + +Write an event to the console. + +=item Test2::Formatter::TAP->register_event($pkg, sub { ... }); + +In general custom events are not supported. There are however occasions where +you might want to write a custom event type that results in TAP output. In +order to do this you use the C class method. + + package My::Event; + use Test2::Formatter::TAP; + + use base 'Test2::Event'; + use Test2::Util::HashBase qw/pass name diag note/; + + Test2::Formatter::TAP->register_event( + __PACKAGE__, + sub { + my $self = shift; + my ($e, $num) = @_; + return ( + [Test2::Formatter::TAP::OUT_STD, "ok $num - " . $e->name . "\n"], + [Test2::Formatter::TAP::OUT_ERR, "# " . $e->name . " " . $e->diag . "\n"], + [Test2::Formatter::TAP::OUT_STD, "# " . $e->name . " " . $e->note . "\n"], + ); + } + ); + + 1; + +=back + +=head2 EVENT METHODS + +All these methods require the event itself. Optionally they can all except a +test number. + +All methods return a list of array-refs. Each array-ref will have 2 items, the +first is an integer identifying an output handle, the second is a string that +should be written to the handle. + +=over 4 + +=item @out = $TAP->event_ok($e) + +=item @out = $TAP->event_ok($e, $num) + +Process an L event. + +=item @out = $TAP->event_plan($e) + +=item @out = $TAP->event_plan($e, $num) + +Process an L event. + +=item @out = $TAP->event_note($e) + +=item @out = $TAP->event_note($e, $num) + +Process an L event. + +=item @out = $TAP->event_diag($e) + +=item @out = $TAP->event_diag($e, $num) + +Process an L event. + +=item @out = $TAP->event_bail($e) + +=item @out = $TAP->event_bail($e, $num) + +Process an L event. + +=item @out = $TAP->event_exception($e) + +=item @out = $TAP->event_exception($e, $num) + +Process an L event. + +=item @out = $TAP->event_skip($e) + +=item @out = $TAP->event_skip($e, $num) + +Process an L event. + +=item @out = $TAP->event_subtest($e) + +=item @out = $TAP->event_subtest($e, $num) + +Process an L event. + +=item @out = $TAP->event_other($e, $num) + +Fallback for unregistered event types. It uses the L API to +convert the event to TAP. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=item Kent Fredric Ekentnl@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Hub.pm b/Master/tlpkg/tlperl/lib/Test2/Hub.pm new file mode 100755 index 00000000000..324f1a87bbb --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Hub.pm @@ -0,0 +1,829 @@ +package Test2::Hub; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +use Carp qw/carp croak confess/; +use Test2::Util qw/get_tid ipc_separator/; + +use Scalar::Util qw/weaken/; + +use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; +use Test2::Util::HashBase qw{ + pid tid hid ipc + no_ending + _filters + _pre_filters + _listeners + _follow_ups + _formatter + _context_acquire + _context_init + _context_release + + active + count + failed + ended + bailed_out + _passing + _plan + skip_reason +}; + +my $ID_POSTFIX = 1; +sub init { + my $self = shift; + + $self->{+PID} = $$; + $self->{+TID} = get_tid(); + $self->{+HID} = join ipc_separator, $self->{+PID}, $self->{+TID}, $ID_POSTFIX++; + + $self->{+COUNT} = 0; + $self->{+FAILED} = 0; + $self->{+_PASSING} = 1; + + if (my $formatter = delete $self->{formatter}) { + $self->format($formatter); + } + + if (my $ipc = $self->{+IPC}) { + $ipc->add_hub($self->{+HID}); + } +} + +sub is_subtest { 0 } + +sub reset_state { + my $self = shift; + + $self->{+COUNT} = 0; + $self->{+FAILED} = 0; + $self->{+_PASSING} = 1; + + delete $self->{+_PLAN}; + delete $self->{+ENDED}; + delete $self->{+BAILED_OUT}; + delete $self->{+SKIP_REASON}; +} + +sub inherit { + my $self = shift; + my ($from, %params) = @_; + + $self->{+_FORMATTER} = $from->{+_FORMATTER} + unless $self->{+_FORMATTER} || exists($params{formatter}); + + if ($from->{+IPC} && !$self->{+IPC} && !exists($params{ipc})) { + my $ipc = $from->{+IPC}; + $self->{+IPC} = $ipc; + $ipc->add_hub($self->{+HID}); + } + + if (my $ls = $from->{+_LISTENERS}) { + push @{$self->{+_LISTENERS}} => grep { $_->{inherit} } @$ls; + } + + if (my $pfs = $from->{+_PRE_FILTERS}) { + push @{$self->{+_PRE_FILTERS}} => grep { $_->{inherit} } @$pfs; + } + + if (my $fs = $from->{+_FILTERS}) { + push @{$self->{+_FILTERS}} => grep { $_->{inherit} } @$fs; + } +} + +sub format { + my $self = shift; + + my $old = $self->{+_FORMATTER}; + ($self->{+_FORMATTER}) = @_ if @_; + + return $old; +} + +sub is_local { + my $self = shift; + return $$ == $self->{+PID} + && get_tid() == $self->{+TID}; +} + +sub listen { + my $self = shift; + my ($sub, %params) = @_; + + carp "Useless addition of a listener in a child process or thread!" + if $$ != $self->{+PID} || get_tid() != $self->{+TID}; + + croak "listen only takes coderefs for arguments, got '$sub'" + unless ref $sub && ref $sub eq 'CODE'; + + push @{$self->{+_LISTENERS}} => { %params, code => $sub }; + + $sub; # Intentional return. +} + +sub unlisten { + my $self = shift; + + carp "Useless removal of a listener in a child process or thread!" + if $$ != $self->{+PID} || get_tid() != $self->{+TID}; + + my %subs = map {$_ => $_} @_; + + @{$self->{+_LISTENERS}} = grep { !$subs{$_->{code}} } @{$self->{+_LISTENERS}}; +} + +sub filter { + my $self = shift; + my ($sub, %params) = @_; + + carp "Useless addition of a filter in a child process or thread!" + if $$ != $self->{+PID} || get_tid() != $self->{+TID}; + + croak "filter only takes coderefs for arguments, got '$sub'" + unless ref $sub && ref $sub eq 'CODE'; + + push @{$self->{+_FILTERS}} => { %params, code => $sub }; + + $sub; # Intentional Return +} + +sub unfilter { + my $self = shift; + carp "Useless removal of a filter in a child process or thread!" + if $$ != $self->{+PID} || get_tid() != $self->{+TID}; + my %subs = map {$_ => $_} @_; + @{$self->{+_FILTERS}} = grep { !$subs{$_->{code}} } @{$self->{+_FILTERS}}; +} + +sub pre_filter { + my $self = shift; + my ($sub, %params) = @_; + + croak "pre_filter only takes coderefs for arguments, got '$sub'" + unless ref $sub && ref $sub eq 'CODE'; + + push @{$self->{+_PRE_FILTERS}} => { %params, code => $sub }; + + $sub; # Intentional Return +} + +sub pre_unfilter { + my $self = shift; + my %subs = map {$_ => $_} @_; + @{$self->{+_PRE_FILTERS}} = grep { !$subs{$_->{code}} } @{$self->{+_PRE_FILTERS}}; +} + +sub follow_up { + my $self = shift; + my ($sub) = @_; + + carp "Useless addition of a follow-up in a child process or thread!" + if $$ != $self->{+PID} || get_tid() != $self->{+TID}; + + croak "follow_up only takes coderefs for arguments, got '$sub'" + unless ref $sub && ref $sub eq 'CODE'; + + push @{$self->{+_FOLLOW_UPS}} => $sub; +} + +*add_context_aquire = \&add_context_acquire; +sub add_context_acquire { + my $self = shift; + my ($sub) = @_; + + croak "add_context_acquire only takes coderefs for arguments, got '$sub'" + unless ref $sub && ref $sub eq 'CODE'; + + push @{$self->{+_CONTEXT_ACQUIRE}} => $sub; + + $sub; # Intentional return. +} + +*remove_context_aquire = \&remove_context_acquire; +sub remove_context_acquire { + my $self = shift; + my %subs = map {$_ => $_} @_; + @{$self->{+_CONTEXT_ACQUIRE}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_ACQUIRE}}; +} + +sub add_context_init { + my $self = shift; + my ($sub) = @_; + + croak "add_context_init only takes coderefs for arguments, got '$sub'" + unless ref $sub && ref $sub eq 'CODE'; + + push @{$self->{+_CONTEXT_INIT}} => $sub; + + $sub; # Intentional return. +} + +sub remove_context_init { + my $self = shift; + my %subs = map {$_ => $_} @_; + @{$self->{+_CONTEXT_INIT}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_INIT}}; +} + +sub add_context_release { + my $self = shift; + my ($sub) = @_; + + croak "add_context_release only takes coderefs for arguments, got '$sub'" + unless ref $sub && ref $sub eq 'CODE'; + + push @{$self->{+_CONTEXT_RELEASE}} => $sub; + + $sub; # Intentional return. +} + +sub remove_context_release { + my $self = shift; + my %subs = map {$_ => $_} @_; + @{$self->{+_CONTEXT_RELEASE}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_RELEASE}}; +} + +sub send { + my $self = shift; + my ($e) = @_; + + if ($self->{+_PRE_FILTERS}) { + for (@{$self->{+_PRE_FILTERS}}) { + $e = $_->{code}->($self, $e); + return unless $e; + } + } + + my $ipc = $self->{+IPC} || return $self->process($e); + + if($e->global) { + $ipc->send($self->{+HID}, $e, 'GLOBAL'); + return $self->process($e); + } + + return $ipc->send($self->{+HID}, $e) + if $$ != $self->{+PID} || get_tid() != $self->{+TID}; + + $self->process($e); +} + +sub process { + my $self = shift; + my ($e) = @_; + + if ($self->{+_FILTERS}) { + for (@{$self->{+_FILTERS}}) { + $e = $_->{code}->($self, $e); + return unless $e; + } + } + + my $type = ref($e); + my $is_ok = $type eq 'Test2::Event::Ok'; + my $no_fail = $type eq 'Test2::Event::Diag' || $type eq 'Test2::Event::Note'; + my $causes_fail = $is_ok ? !$e->{effective_pass} : $no_fail ? 0 : $e->causes_fail; + my $counted = $is_ok || (!$no_fail && $e->increments_count); + + $self->{+COUNT}++ if $counted; + $self->{+FAILED}++ if $causes_fail && $counted; + $self->{+_PASSING} = 0 if $causes_fail; + + my $callback = $e->callback($self) unless $is_ok || $no_fail; + + my $count = $self->{+COUNT}; + + $self->{+_FORMATTER}->write($e, $count) if $self->{+_FORMATTER}; + + if ($self->{+_LISTENERS}) { + $_->{code}->($self, $e, $count) for @{$self->{+_LISTENERS}}; + } + + return $e if $is_ok || $no_fail; + + my $code = $e->terminate; + if (defined $code) { + $self->{+_FORMATTER}->terminate($e) if $self->{+_FORMATTER}; + $self->terminate($code, $e); + } + + return $e; +} + +sub terminate { + my $self = shift; + my ($code) = @_; + exit($code); +} + +sub cull { + my $self = shift; + + my $ipc = $self->{+IPC} || return; + return if $self->{+PID} != $$ || $self->{+TID} != get_tid(); + + # No need to do IPC checks on culled events + $self->process($_) for $ipc->cull($self->{+HID}); +} + +sub finalize { + my $self = shift; + my ($trace, $do_plan) = @_; + + $self->cull(); + + my $plan = $self->{+_PLAN}; + my $count = $self->{+COUNT}; + my $failed = $self->{+FAILED}; + my $active = $self->{+ACTIVE}; + + # return if NOTHING was done. + unless ($active || $do_plan || defined($plan) || $count || $failed) { + $self->{+_FORMATTER}->finalize($plan, $count, $failed, 0, $self->is_subtest) if $self->{+_FORMATTER}; + return; + } + + unless ($self->{+ENDED}) { + if ($self->{+_FOLLOW_UPS}) { + $_->($trace, $self) for reverse @{$self->{+_FOLLOW_UPS}}; + } + + # These need to be refreshed now + $plan = $self->{+_PLAN}; + $count = $self->{+COUNT}; + $failed = $self->{+FAILED}; + + if (($plan && $plan eq 'NO PLAN') || ($do_plan && !$plan)) { + $self->send( + Test2::Event::Plan->new( + trace => $trace, + max => $count, + ) + ); + } + $plan = $self->{+_PLAN}; + } + + my $frame = $trace->frame; + if($self->{+ENDED}) { + my (undef, $ffile, $fline) = @{$self->{+ENDED}}; + my (undef, $sfile, $sline) = @$frame; + + die <<" EOT" +Test already ended! +First End: $ffile line $fline +Second End: $sfile line $sline + EOT + } + + $self->{+ENDED} = $frame; + my $pass = $self->is_passing(); # Generate the final boolean. + + $self->{+_FORMATTER}->finalize($plan, $count, $failed, $pass, $self->is_subtest) if $self->{+_FORMATTER}; + + return $pass; +} + +sub is_passing { + my $self = shift; + + ($self->{+_PASSING}) = @_ if @_; + + # If we already failed just return 0. + my $pass = $self->{+_PASSING} or return 0; + return $self->{+_PASSING} = 0 if $self->{+FAILED}; + + my $count = $self->{+COUNT}; + my $ended = $self->{+ENDED}; + my $plan = $self->{+_PLAN}; + + return $pass if !$count && $plan && $plan =~ m/^SKIP$/; + + return $self->{+_PASSING} = 0 + if $ended && (!$count || !$plan); + + return $pass unless $plan && $plan =~ m/^\d+$/; + + if ($ended) { + return $self->{+_PASSING} = 0 if $count != $plan; + } + else { + return $self->{+_PASSING} = 0 if $count > $plan; + } + + return $pass; +} + +sub plan { + my $self = shift; + + return $self->{+_PLAN} unless @_; + + my ($plan) = @_; + + confess "You cannot unset the plan" + unless defined $plan; + + confess "You cannot change the plan" + if $self->{+_PLAN} && $self->{+_PLAN} !~ m/^NO PLAN$/; + + confess "'$plan' is not a valid plan! Plan must be an integer greater than 0, 'NO PLAN', or 'SKIP'" + unless $plan =~ m/^(\d+|NO PLAN|SKIP)$/; + + $self->{+_PLAN} = $plan; +} + +sub check_plan { + my $self = shift; + + return undef unless $self->{+ENDED}; + my $plan = $self->{+_PLAN} || return undef; + + return 1 if $plan !~ m/^\d+$/; + + return 1 if $plan == $self->{+COUNT}; + return 0; +} + +sub DESTROY { + my $self = shift; + my $ipc = $self->{+IPC} || return; + return unless $$ == $self->{+PID}; + return unless get_tid() == $self->{+TID}; + + $ipc->drop_hub($self->{+HID}); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Hub - The conduit through which all events flow. + +=head1 SYNOPSIS + + use Test2::Hub; + + my $hub = Test2::Hub->new(); + $hub->send(...); + +=head1 DESCRIPTION + +The hub is the place where all events get processed and handed off to the +formatter. The hub also tracks test state, and provides several hooks into the +event pipeline. + +=head1 COMMON TASKS + +=head2 SENDING EVENTS + + $hub->send($event) + +The C method is used to issue an event to the hub. This method will +handle thread/fork sync, filters, listeners, TAP output, etc. + +=head2 ALTERING OR REMOVING EVENTS + +You can use either C or C, depending on your +needs. Both have identical syntax, so only C is shown here. + + $hub->filter(sub { + my ($hub, $event) = @_; + + my $action = get_action($event); + + # No action should be taken + return $event if $action eq 'none'; + + # You want your filter to remove the event + return undef if $action eq 'delete'; + + if ($action eq 'do_it') { + my $new_event = copy_event($event); + ... Change your copy of the event ... + return $new_event; + } + + die "Should not happen"; + }); + +By default, filters are not inherited by child hubs. That means if you start a +subtest, the subtest will not inherit the filter. You can change this behavior +with the C parameter: + + $hub->filter(sub { ... }, inherit => 1); + +=head2 LISTENING FOR EVENTS + + $hub->listen(sub { + my ($hub, $event, $number) = @_; + + ... do whatever you want with the event ... + + # return is ignored + }); + +By default listeners are not inherited by child hubs. That means if you start a +subtest, the subtest will not inherit the listener. You can change this behavior +with the C parameter: + + $hub->listen(sub { ... }, inherit => 1); + + +=head2 POST-TEST BEHAVIORS + + $hub->follow_up(sub { + my ($trace, $hub) = @_; + + ... do whatever you need to ... + + # Return is ignored + }); + +follow_up subs are called only once, either when done_testing is called, or in +an END block. + +=head2 SETTING THE FORMATTER + +By default an instance of L is created and used. + + my $old = $hub->format(My::Formatter->new); + +Setting the formatter will REPLACE any existing formatter. You may set the +formatter to undef to prevent output. The old formatter will be returned if one +was already set. Only one formatter is allowed at a time. + +=head1 METHODS + +=over 4 + +=item $hub->send($event) + +This is where all events enter the hub for processing. + +=item $hub->process($event) + +This is called by send after it does any IPC handling. You can use this to +bypass the IPC process, but in general you should avoid using this. + +=item $old = $hub->format($formatter) + +Replace the existing formatter instance with a new one. Formatters must be +objects that implement a C<< $formatter->write($event) >> method. + +=item $sub = $hub->listen(sub { ... }, %optional_params) + +You can use this to record all events AFTER they have been sent to the +formatter. No changes made here will be meaningful, except possibly to other +listeners. + + $hub->listen(sub { + my ($hub, $event, $number) = @_; + + ... do whatever you want with the event ... + + # return is ignored + }); + +Normally listeners are not inherited by child hubs such as subtests. You can +add the C<< inherit => 1 >> parameter to allow a listener to be inherited. + +=item $hub->unlisten($sub) + +You can use this to remove a listen callback. You must pass in the coderef +returned by the C method. + +=item $sub = $hub->filter(sub { ... }, %optional_params) + +=item $sub = $hub->pre_filter(sub { ... }, %optional_params) + +These can be used to add filters. Filters can modify, replace, or remove events +before anything else can see them. + + $hub->filter( + sub { + my ($hub, $event) = @_; + + return $event; # No Changes + return; # Remove the event + + # Or you can modify an event before returning it. + $event->modify; + return $event; + } + ); + +If you are not using threads, forking, or IPC then the only difference between +a C and a C is that C subs run first. When you +are using threads, forking, or IPC, pre_filters happen to events before they +are sent to their destination proc/thread, ordinary filters happen only in the +destination hub/thread. + +You cannot add a regular filter to a hub if the hub was created in another +process or thread. You can always add a pre_filter. + +=item $hub->unfilter($sub) + +=item $hub->pre_unfilter($sub) + +These can be used to remove filters and pre_filters. The C<$sub> argument is +the reference returned by C or C. + +=item $hub->follow_op(sub { ... }) + +Use this to add behaviors that are called just before the hub is finalized. The +only argument to your codeblock will be a L instance. + + $hub->follow_up(sub { + my ($trace, $hub) = @_; + + ... do whatever you need to ... + + # Return is ignored + }); + +follow_up subs are called only once, ether when done_testing is called, or in +an END block. + +=item $sub = $hub->add_context_acquire(sub { ... }); + +Add a callback that will be called every time someone tries to acquire a +context. It gets a single argument, a reference of the hash of parameters +being used the construct the context. This is your chance to change the +parameters by directly altering the hash. + + test2_add_callback_context_acquire(sub { + my $params = shift; + $params->{level}++; + }); + +This is a very scary API function. Please do not use this unless you need to. +This is here for L and backwards compatibility. This has you +directly manipulate the hash instead of returning a new one for performance +reasons. + +B Using this hook could have a huge performance impact. + +The coderef you provide is returned and can be used to remove the hook later. + +=item $hub->remove_context_acquire($sub); + +This can be used to remove a context acquire hook. + +=item $sub = $hub->add_context_init(sub { ... }); + +This allows you to add callbacks that will trigger every time a new context is +created for the hub. The only argument to the sub will be the +L instance that was created. + +B Using this hook could have a huge performance impact. + +The coderef you provide is returned and can be used to remove the hook later. + +=item $hub->remove_context_init($sub); + +This can be used to remove a context init hook. + +=item $sub = $hub->add_context_release(sub { ... }); + +This allows you to add callbacks that will trigger every time a context for +this hub is released. The only argument to the sub will be the +L instance that was released. These will run in reverse +order. + +B Using this hook could have a huge performance impact. + +The coderef you provide is returned and can be used to remove the hook later. + +=item $hub->remove_context_release($sub); + +This can be used to remove a context release hook. + +=item $hub->cull() + +Cull any IPC events (and process them). + +=item $pid = $hub->pid() + +Get the process id under which the hub was created. + +=item $tid = $hub->tid() + +Get the thread id under which the hub was created. + +=item $hud = $hub->hid() + +Get the identifier string of the hub. + +=item $ipc = $hub->ipc() + +Get the IPC object used by the hub. + +=item $hub->set_no_ending($bool) + +=item $bool = $hub->no_ending + +This can be used to disable auto-ending behavior for a hub. The auto-ending +behavior is triggered by an end block and is used to cull IPC events, and +output the final plan if the plan was 'no_plan'. + +=item $bool = $hub->active + +=item $hub->set_active($bool) + +These are used to get/set the 'active' attribute. When true this attribute will +force C<< hub->finalize() >> to take action even if there is no plan, and no +tests have been run. This flag is useful for plugins that add follow-up +behaviors that need to run even if no events are seen. + +=back + +=head2 STATE METHODS + +=over 4 + +=item $hub->reset_state() + +Reset all state to the start. This sets the test count to 0, clears the plan, +removes the failures, etc. + +=item $num = $hub->count + +Get the number of tests that have been run. + +=item $num = $hub->failed + +Get the number of failures (Not all failures come from a test fail, so this +number can be larger than the count). + +=item $bool = $hub->ended + +True if the testing has ended. This MAY return the stack frame of the tool that +ended the test, but that is not guaranteed. + +=item $bool = $hub->is_passing + +=item $hub->is_passing($bool) + +Check if the overall test run is a failure. Can also be used to set the +pass/fail status. + +=item $hub->plan($plan) + +=item $plan = $hub->plan + +Get or set the plan. The plan must be an integer larger than 0, the string +'no_plan', or the string 'skip_all'. + +=item $bool = $hub->check_plan + +Check if the plan and counts match, but only if the tests have ended. If tests +have not ended this will return undef, otherwise it will be a true/false. + +=back + +=head1 THIRD PARTY META-DATA + +This object consumes L which provides a consistent +way for you to attach meta-data to instances of this class. This is useful for +tools, plugins, and other extensions. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Hub/Interceptor.pm b/Master/tlpkg/tlperl/lib/Test2/Hub/Interceptor.pm new file mode 100755 index 00000000000..42be265f8d7 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Hub/Interceptor.pm @@ -0,0 +1,80 @@ +package Test2::Hub::Interceptor; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +use Test2::Hub::Interceptor::Terminator(); + +BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) } +use Test2::Util::HashBase; + +sub inherit { + my $self = shift; + my ($from, %params) = @_; + + if ($from->{+IPC} && !$self->{+IPC} && !exists($params{ipc})) { + my $ipc = $from->{+IPC}; + $self->{+IPC} = $ipc; + $ipc->add_hub($self->{+HID}); + } +} + +sub terminate { + my $self = shift; + my ($code) = @_; + + eval { + no warnings 'exiting'; + last T2_SUBTEST_WRAPPER; + }; + my $err = $@; + + # Fallback + die bless(\$err, 'Test2::Hub::Interceptor::Terminator'); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Hub::Interceptor - Hub used by interceptor to grab results. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Hub/Interceptor/Terminator.pm b/Master/tlpkg/tlperl/lib/Test2/Hub/Interceptor/Terminator.pm new file mode 100755 index 00000000000..f7201904689 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Hub/Interceptor/Terminator.pm @@ -0,0 +1,51 @@ +package Test2::Hub::Interceptor::Terminator; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Hub::Interceptor::Terminator - Exception class used by +Test2::Hub::Interceptor + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Hub/Subtest.pm b/Master/tlpkg/tlperl/lib/Test2/Hub/Subtest.pm new file mode 100755 index 00000000000..adb3d6f15ed --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Hub/Subtest.pm @@ -0,0 +1,125 @@ +package Test2::Hub::Subtest; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) } +use Test2::Util::HashBase qw/nested bailed_out exit_code manual_skip_all id/; +use Test2::Util qw/get_tid/; + +my $ID = 1; +sub init { + my $self = shift; + $self->SUPER::init(@_); + $self->{+ID} ||= join "-", $$, get_tid, $ID++; +} + +sub is_subtest { 1 } + +sub process { + my $self = shift; + my ($e) = @_; + $e->set_nested($self->nested); + $e->set_in_subtest($self->{+ID}); + $self->set_bailed_out($e) if $e->isa('Test2::Event::Bail'); + $self->SUPER::process($e); +} + +sub send { + my $self = shift; + my ($e) = @_; + + my $out = $self->SUPER::send($e); + + return $out if $self->{+MANUAL_SKIP_ALL}; + return $out unless $e->isa('Test2::Event::Plan') + && $e->directive eq 'SKIP' + && ($e->trace->pid != $self->pid || $e->trace->tid != $self->tid); + + no warnings 'exiting'; + last T2_SUBTEST_WRAPPER; +} + +sub terminate { + my $self = shift; + my ($code, $e) = @_; + $self->set_exit_code($code); + + return if $self->{+MANUAL_SKIP_ALL}; + return if $e->isa('Test2::Event::Plan') + && $e->directive eq 'SKIP' + && ($e->trace->pid != $$ || $e->trace->tid != get_tid); + + no warnings 'exiting'; + last T2_SUBTEST_WRAPPER; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Hub::Subtest - Hub used by subtests + +=head1 DESCRIPTION + +Subtests make use of this hub to route events. + +=head1 TOGGLES + +=over 4 + +=item $bool = $hub->manual_skip_all + +=item $hub->set_manual_skip_all($bool) + +The default is false. + +Normally a skip-all plan event will cause a subtest to stop executing. This is +accomplished via C to a label inside the subtest code. Most of the +time this is perfectly fine. There are times however where this flow control +causes bad things to happen. + +This toggle lets you turn off the abort logic for the hub. When this is toggled +to true B are responsible for ensuring no additional events are generated. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/IPC.pm b/Master/tlpkg/tlperl/lib/Test2/IPC.pm new file mode 100755 index 00000000000..92447919c11 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/IPC.pm @@ -0,0 +1,140 @@ +package Test2::IPC; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +use Test2::API::Instance; +use Test2::Util qw/get_tid/; +use Test2::API qw{ + test2_init_done + test2_ipc + test2_ipc_enable_polling + test2_pid + test2_stack + test2_tid + context +}; + +use Carp qw/confess/; + +our @EXPORT_OK = qw/cull/; +BEGIN { require Exporter; our @ISA = qw(Exporter) } + +sub import { + goto &Exporter::import unless test2_init_done(); + + confess "Cannot add IPC in a child process (" . test2_pid() . " vs $$)" if test2_pid() != $$; + confess "Cannot add IPC in a child thread (" . test2_tid() . " vs " . get_tid() . ")" if test2_tid() != get_tid(); + + Test2::API::_set_ipc(_make_ipc()); + apply_ipc(test2_stack()); + + goto &Exporter::import; +} + +sub _make_ipc { + # Find a driver + my ($driver) = Test2::API::test2_ipc_drivers(); + unless ($driver) { + require Test2::IPC::Driver::Files; + $driver = 'Test2::IPC::Driver::Files'; + } + + return $driver->new(); +} + +sub apply_ipc { + my $stack = shift; + + my ($root) = @$stack; + + return unless $root; + + confess "Cannot add IPC in a child process" if $root->pid != $$; + confess "Cannot add IPC in a child thread" if $root->tid != get_tid(); + + my $ipc = $root->ipc || test2_ipc() || _make_ipc(); + + # Add the IPC to all hubs + for my $hub (@$stack) { + my $has = $hub->ipc; + confess "IPC Mismatch!" if $has && $has != $ipc; + next if $has; + $hub->set_ipc($ipc); + $ipc->add_hub($hub->hid); + } + + test2_ipc_enable_polling(); + + return $ipc; +} + +sub cull { + my $ctx = context(); + $ctx->hub->cull; + $ctx->release; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::IPC - Turn on IPC for threading or forking support. + +=head1 SYNOPSIS + +You should C as early as possible in your test file. If you +import this module after API initialization it will attempt to retrofit IPC +onto the existing hubs. + +=head1 EXPORTS + +All exports are optional. + +=over 4 + +=item cull() + +Cull allows you to collect results from other processes or threads on demand. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/IPC/Driver.pm b/Master/tlpkg/tlperl/lib/Test2/IPC/Driver.pm new file mode 100755 index 00000000000..cd34f7c0258 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/IPC/Driver.pm @@ -0,0 +1,292 @@ +package Test2::IPC::Driver; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +use Carp qw/confess longmess/; +use Test2::Util::HashBase qw{no_fatal}; + +use Test2::API qw/test2_ipc_add_driver/; + +my %ADDED; +sub import { + my $class = shift; + return if $class eq __PACKAGE__; + return if $ADDED{$class}++; + test2_ipc_add_driver($class); +} + +sub use_shm { 0 } + +for my $meth (qw/send cull add_hub drop_hub waiting is_viable/) { + no strict 'refs'; + *$meth = sub { + my $thing = shift; + confess "'$thing' did not define the required method '$meth'." + }; +} + +# Print the error and call exit. We are not using 'die' cause this is a +# catastrophic error that should never be caught. If we get here it +# means some serious shit has happened in a child process, the only way +# to inform the parent may be to exit false. + +sub abort { + my $self = shift; + chomp(my ($msg) = @_); + print STDERR "IPC Fatal Error: $msg\n"; + print STDOUT "not ok - IPC Fatal Error\n"; + + CORE::exit(255) unless $self->no_fatal; +} + +sub abort_trace { + my $self = shift; + my ($msg) = @_; + $self->abort(longmess($msg)); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::IPC::Driver - Base class for Test2 IPC drivers. + +=head1 SYNOPSIS + + package Test2::IPC::Driver::MyDriver; + + use base 'Test2::IPC::Driver'; + + ... + +=head1 METHODS + +=over 4 + +=item $self->abort($msg) + +If an IPC encounters a fatal error it should use this. This will print the +message to STDERR with C<'IPC Fatal Error: '> prefixed to it, then it will +forcefully exit 255. IPC errors may occur in threads or processes other than +the main one, this method provides the best chance of the harness noticing the +error. + +=item $self->abort_trace($msg) + +This is the same as C<< $ipc->abort($msg) >> except that it uses +C to add a stack trace to the message. + +=item $false = $self->use_shm + +The base class always returns false for this method. You may override it if you +wish to use the SHM made available in L/L. + +=back + +=head1 LOADING DRIVERS + +Test2::IPC::Driver has an C method. All drivers inherit this import +method. This import method registers the driver. + +In most cases you just need to load the desired IPC driver to make it work. You +should load this driver as early as possible. A warning will be issued if you +load it too late for it to be effective. + + use Test2::IPC::Driver::MyDriver; + ... + +=head1 WRITING DRIVERS + + package Test2::IPC::Driver::MyDriver; + use strict; + use warnings; + + use base 'Test2::IPC::Driver'; + + sub is_viable { + return 0 if $^O eq 'win32'; # Will not work on windows. + return 1; + } + + sub add_hub { + my $self = shift; + my ($hid) = @_; + + ... # Make it possible to contact the hub + } + + sub drop_hub { + my $self = shift; + my ($hid) = @_; + + ... # Nothing should try to reach the hub anymore. + } + + sub send { + my $self = shift; + my ($hid, $e, $global) = @_; + + ... # Send the event to the proper hub. + + # If you are using the SHM you should notify other procs/threads that + # there is a pending event. + Test2::API::test2_ipc_set_pending($uniq_val); + } + + sub cull { + my $self = shift; + my ($hid) = @_; + + my @events = ...; # Here is where you get the events for the hub + + return @events; + } + + sub waiting { + my $self = shift; + + ... # Notify all listening procs and threads that the main + ... # process/thread is waiting for them to finish. + } + + 1; + +=head2 METHODS SUBCLASSES MUST IMPLEMENT + +=over 4 + +=item $ipc->is_viable + +This should return true if the driver works in the current environment. This +should return false if it does not. This is a CLASS method. + +=item $ipc->add_hub($hid) + +This is used to alert the driver that a new hub is expecting events. The driver +should keep track of the process and thread ids, the hub should only be dropped +by the proc+thread that started it. + + sub add_hub { + my $self = shift; + my ($hid) = @_; + + ... # Make it possible to contact the hub + } + +=item $ipc->drop_hub($hid) + +This is used to alert the driver that a hub is no longer accepting events. The +driver should keep track of the process and thread ids, the hub should only be +dropped by the proc+thread that started it (This is the drivers responsibility +to enforce). + + sub drop_hub { + my $self = shift; + my ($hid) = @_; + + ... # Nothing should try to reach the hub anymore. + } + +=item $ipc->send($hid, $event); + +=item $ipc->send($hid, $event, $global); + +Used to send events from the current process/thread to the specified hub in its +process+thread. + + sub send { + my $self = shift; + my ($hid, $e) = @_; + + ... # Send the event to the proper hub. + + # If you are using the SHM you should notify other procs/threads that + # there is a pending event. + Test2::API::test2_ipc_set_pending($uniq_val); + } + +If C<$global> is true then the driver should send the event to all hubs in all +processes and threads. + +=item @events = $ipc->cull($hid) + +Used to collect events that have been sent to the specified hub. + + sub cull { + my $self = shift; + my ($hid) = @_; + + my @events = ...; # Here is where you get the events for the hub + + return @events; + } + +=item $ipc->waiting() + +This is called in the parent process when it is complete and waiting for all +child processes and threads to complete. + + sub waiting { + my $self = shift; + + ... # Notify all listening procs and threads that the main + ... # process/thread is waiting for them to finish. + } + +=back + +=head2 METHODS SUBCLASSES MAY IMPLEMENT OR OVERRIDE + +=over 4 + +=item $bool = $ipc->use_shm() + +True if you want to make use of the L/L SHM. + +=item $bites = $ipc->shm_size() + +Use this to customize the size of the SHM space. There are no guarantees about +what the size will be if you do not implement this. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/IPC/Driver/Files.pm b/Master/tlpkg/tlperl/lib/Test2/IPC/Driver/Files.pm new file mode 100755 index 00000000000..998fef56376 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/IPC/Driver/Files.pm @@ -0,0 +1,497 @@ +package Test2::IPC::Driver::Files; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +BEGIN { require Test2::IPC::Driver; our @ISA = qw(Test2::IPC::Driver) } + +use Test2::Util::HashBase qw{tempdir event_id tid pid globals}; + +use Scalar::Util qw/blessed/; +use File::Temp(); +use Storable(); +use File::Spec(); +use POSIX(); + +use Test2::Util qw/try get_tid pkg_to_file IS_WIN32 ipc_separator/; +use Test2::API qw/test2_ipc_set_pending/; + +BEGIN { + if (IS_WIN32) { + my $max_tries = 5; + + *do_rename = sub { + my ($from, $to) = @_; + + my $err; + for (1 .. $max_tries) { + return (1) if rename($from, $to); + $err = "$!"; + last if $_ == $max_tries; + sleep 1; + } + + return (0, $err); + }; + *do_unlink = sub { + my ($file) = @_; + + my $err; + for (1 .. $max_tries) { + return (1) if unlink($file); + $err = "$!"; + last if $_ == $max_tries; + sleep 1; + } + + return (0, "$!"); + }; + } + else { + *do_rename = sub { + my ($from, $to) = @_; + return (1) if rename($from, $to); + return (0, "$!"); + }; + *do_unlink = sub { + my ($file) = @_; + return (1) if unlink($file); + return (0, "$!"); + }; + } +} + +sub use_shm { 1 } +sub shm_size() { 64 } + +sub is_viable { 1 } + +sub init { + my $self = shift; + + my $tmpdir = File::Temp::tempdir( + $ENV{T2_TEMPDIR_TEMPLATE} || "test2" . ipc_separator . $$ . ipc_separator . "XXXXXX", + CLEANUP => 0, + TMPDIR => 1, + ); + + $self->abort_trace("Could not get a temp dir") unless $tmpdir; + + $self->{+TEMPDIR} = File::Spec->canonpath($tmpdir); + + print STDERR "\nIPC Temp Dir: $tmpdir\n\n" + if $ENV{T2_KEEP_TEMPDIR}; + + $self->{+EVENT_ID} = 1; + + $self->{+TID} = get_tid(); + $self->{+PID} = $$; + + $self->{+GLOBALS} = {}; + + return $self; +} + +sub hub_file { + my $self = shift; + my ($hid) = @_; + my $tdir = $self->{+TEMPDIR}; + return File::Spec->catfile($tdir, "HUB" . ipc_separator . $hid); +} + +sub event_file { + my $self = shift; + my ($hid, $e) = @_; + + my $tempdir = $self->{+TEMPDIR}; + my $type = blessed($e) or $self->abort("'$e' is not a blessed object!"); + + $self->abort("'$e' is not an event object!") + unless $type->isa('Test2::Event'); + + my @type = split '::', $type; + my $name = join(ipc_separator, $hid, $$, get_tid(), $self->{+EVENT_ID}++, @type); + + return File::Spec->catfile($tempdir, $name); +} + +sub add_hub { + my $self = shift; + my ($hid) = @_; + + my $hfile = $self->hub_file($hid); + + $self->abort_trace("File for hub '$hid' already exists") + if -e $hfile; + + open(my $fh, '>', $hfile) or $self->abort_trace("Could not create hub file '$hid': $!"); + print $fh "$$\n" . get_tid() . "\n"; + close($fh); +} + +sub drop_hub { + my $self = shift; + my ($hid) = @_; + + my $tdir = $self->{+TEMPDIR}; + my $hfile = $self->hub_file($hid); + + $self->abort_trace("File for hub '$hid' does not exist") + unless -e $hfile; + + open(my $fh, '<', $hfile) or $self->abort_trace("Could not open hub file '$hid': $!"); + my ($pid, $tid) = <$fh>; + close($fh); + + $self->abort_trace("A hub file can only be closed by the process that started it\nExpected $pid, got $$") + unless $pid == $$; + + $self->abort_trace("A hub file can only be closed by the thread that started it\nExpected $tid, got " . get_tid()) + unless get_tid() == $tid; + + if ($ENV{T2_KEEP_TEMPDIR}) { + my ($ok, $err) = do_rename($hfile, File::Spec->canonpath("$hfile.complete")); + $self->abort_trace("Could not rename file '$hfile' -> '$hfile.complete': $err") unless $ok + } + else { + my ($ok, $err) = do_unlink($hfile); + $self->abort_trace("Could not remove file for hub '$hid': $err") unless $ok + } + + opendir(my $dh, $tdir) or $self->abort_trace("Could not open temp dir!"); + for my $file (readdir($dh)) { + next if $file =~ m{\.complete$}; + next unless $file =~ m{^$hid}; + $self->abort_trace("Not all files from hub '$hid' have been collected!"); + } + closedir($dh); +} + +sub send { + my $self = shift; + my ($hid, $e, $global) = @_; + + my $tempdir = $self->{+TEMPDIR}; + my $hfile = $self->hub_file($hid); + my $dest = $global ? 'GLOBAL' : $hid; + + $self->abort(<<" EOT") unless $global || -f $hfile; +hub '$hid' is not available, failed to send event! + +There was an attempt to send an event to a hub in a parent process or thread, +but that hub appears to be gone. This can happen if you fork, or start a new +thread from inside subtest, and the parent finishes the subtest before the +child returns. + +This can also happen if the parent process is done testing before the child +finishes. Test2 normally waits automatically in the root process, but will not +do so if Test::Builder is loaded for legacy reasons. + EOT + + my $file = $self->event_file($dest, $e); + my $ready = File::Spec->canonpath("$file.ready"); + + if ($global) { + my $name = $ready; + $name =~ s{^.*(GLOBAL)}{GLOBAL}; + $self->{+GLOBALS}->{$hid}->{$name}++; + } + + my ($old, $blocked); + unless(IS_WIN32) { + my $to_block = POSIX::SigSet->new( + POSIX::SIGINT(), + POSIX::SIGALRM(), + POSIX::SIGHUP(), + POSIX::SIGTERM(), + POSIX::SIGUSR1(), + POSIX::SIGUSR2(), + ); + $old = POSIX::SigSet->new; + $blocked = POSIX::sigprocmask(POSIX::SIG_BLOCK(), $to_block, $old); + # Silently go on if we failed to log signals, not much we can do. + } + + # Write and rename the file. + my ($ok, $err) = try { + Storable::store($e, $file); + my ($ok, $err) = do_rename("$file", $ready); + unless ($ok) { + POSIX::sigprocmask(POSIX::SIG_SETMASK(), $old, POSIX::SigSet->new()) if defined $blocked; + $self->abort("Could not rename file '$file' -> '$ready': $err"); + }; + test2_ipc_set_pending(substr($file, -(shm_size))); + }; + + # If our block was successful we want to restore the old mask. + POSIX::sigprocmask(POSIX::SIG_SETMASK(), $old, POSIX::SigSet->new()) if defined $blocked; + + if (!$ok) { + my $src_file = __FILE__; + $err =~ s{ at \Q$src_file\E.*$}{}; + chomp($err); + my $tid = get_tid(); + my $trace = $e->trace->debug; + my $type = blessed($e); + + $self->abort(<<" EOT"); + +******************************************************************************* +There was an error writing an event: +Destination: $dest +Origin PID: $$ +Origin TID: $tid +Event Type: $type +Event Trace: $trace +File Name: $file +Ready Name: $ready +Error: $err +******************************************************************************* + + EOT + } + + return 1; +} + +sub cull { + my $self = shift; + my ($hid) = @_; + + my $tempdir = $self->{+TEMPDIR}; + + opendir(my $dh, $tempdir) or $self->abort("could not open IPC temp dir ($tempdir)!"); + + my @out; + for my $info (sort cmp_events map { $self->should_read_event($hid, $_) } readdir($dh)) { + my $full = $info->{full_path}; + my $obj = $self->read_event_file($full); + push @out => $obj; + + # Do not remove global events + next if $info->{global}; + + if ($ENV{T2_KEEP_TEMPDIR}) { + my $complete = File::Spec->canonpath("$full.complete"); + my ($ok, $err) = do_rename($full, $complete); + $self->abort("Could not rename IPC file '$full', '$complete': $err") unless $ok; + } + else { + my ($ok, $err) = do_unlink("$full"); + $self->abort("Could not unlink IPC file '$full': $err") unless $ok; + } + } + + closedir($dh); + return @out; +} + +sub parse_event_filename { + my $self = shift; + my ($file) = @_; + + # The || is to force 0 in false + my $complete = substr($file, -9, 9) eq '.complete' || 0 and substr($file, -9, 9, ""); + my $ready = substr($file, -6, 6) eq '.ready' || 0 and substr($file, -6, 6, ""); + + my @parts = split ipc_separator, $file; + my ($global, $hid) = $parts[0] eq 'GLOBAL' ? (1, shift @parts) : (0, join ipc_separator, splice(@parts, 0, 3)); + my ($pid, $tid, $eid) = splice(@parts, 0, 3); + my $type = join '::' => @parts; + + return { + ready => $ready, + complete => $complete, + global => $global, + type => $type, + hid => $hid, + pid => $pid, + tid => $tid, + eid => $eid, + }; +} + +sub should_read_event { + my $self = shift; + my ($hid, $file) = @_; + + return if substr($file, 0, 1) eq '.'; + + my $parsed = $self->parse_event_filename($file); + + return if $parsed->{complete}; + return unless $parsed->{ready}; + return unless $parsed->{global} || $parsed->{hid} eq $hid; + + return if $parsed->{global} && $self->{+GLOBALS}->{$hid}->{$file}++; + + # Untaint the path. + my $full = File::Spec->catfile($self->{+TEMPDIR}, $file); + ($full) = ($full =~ m/^(.*)$/gs) if ${^TAINT}; + + $parsed->{full_path} = $full; + + return $parsed; +} + +sub cmp_events { + # Globals first + return -1 if $a->{global} && !$b->{global}; + return 1 if $b->{global} && !$a->{global}; + + return $a->{pid} <=> $b->{pid} + || $a->{tid} <=> $b->{tid} + || $a->{eid} <=> $b->{eid}; +} + +sub read_event_file { + my $self = shift; + my ($file) = @_; + + my $obj = Storable::retrieve($file); + $self->abort("Got an unblessed object: '$obj'") + unless blessed($obj); + + unless ($obj->isa('Test2::Event')) { + my $pkg = blessed($obj); + my $mod_file = pkg_to_file($pkg); + my ($ok, $err) = try { require $mod_file }; + + $self->abort("Event has unknown type ($pkg), tried to load '$mod_file' but failed: $err") + unless $ok; + + $self->abort("'$obj' is not a 'Test2::Event' object") + unless $obj->isa('Test2::Event'); + } + + return $obj; +} + +sub waiting { + my $self = shift; + require Test2::Event::Waiting; + $self->send( + GLOBAL => Test2::Event::Waiting->new( + trace => Test2::Util::Trace->new(frame => [caller()]), + ), + 'GLOBAL' + ); + return; +} + +sub DESTROY { + my $self = shift; + + return unless defined $self->pid; + return unless defined $self->tid; + + return unless $$ == $self->pid; + return unless get_tid() == $self->tid; + + my $tempdir = $self->{+TEMPDIR}; + + opendir(my $dh, $tempdir) or $self->abort("Could not open temp dir! ($tempdir)"); + while(my $file = readdir($dh)) { + next if $file =~ m/^\.+$/; + next if $file =~ m/\.complete$/; + my $full = File::Spec->catfile($tempdir, $file); + + my $sep = ipc_separator; + if ($file =~ m/^(GLOBAL|HUB$sep)/) { + $full =~ m/^(.*)$/; + $full = $1; # Untaint it + next if $ENV{T2_KEEP_TEMPDIR}; + my ($ok, $err) = do_unlink($full); + $self->abort("Could not unlink IPC file '$full': $err") unless $ok; + next; + } + + $self->abort("Leftover files in the directory ($full)!\n"); + } + closedir($dh); + + if ($ENV{T2_KEEP_TEMPDIR}) { + print STDERR "# Not removing temp dir: $tempdir\n"; + return; + } + + rmdir($tempdir) or warn "Could not remove IPC temp dir ($tempdir)"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::IPC::Driver::Files - Temp dir + Files concurrency model. + +=head1 DESCRIPTION + +This is the default, and fallback concurrency model for L. This +sends events between processes and threads using serialized files in a +temporary directory. This is not particularly fast, but it works everywhere. + +=head1 SYNOPSIS + + use Test2::IPC::Driver::Files; + + # IPC is now enabled + +=head1 ENVIRONMENT VARIABLES + +=over 4 + +=item T2_KEEP_TEMPDIR=0 + +When true, the tempdir used by the IPC driver will not be deleted when the test +is done. + +=item T2_TEMPDIR_TEMPLATE='test2-XXXXXX' + +This can be used to set the template for the IPC temp dir. The template should +follow template specifications from L. + +=back + +=head1 SEE ALSO + +See L for methods. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Tools/Tiny.pm b/Master/tlpkg/tlperl/lib/Test2/Tools/Tiny.pm new file mode 100755 index 00000000000..857a923c6a2 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Tools/Tiny.pm @@ -0,0 +1,425 @@ +package Test2::Tools::Tiny; +use strict; +use warnings; + +use Scalar::Util qw/blessed/; + +use Test2::Util qw/try/; +use Test2::API qw/context run_subtest test2_stack/; + +use Test2::Hub::Interceptor(); +use Test2::Hub::Interceptor::Terminator(); + +our $VERSION = '1.302073'; + +BEGIN { require Exporter; our @ISA = qw(Exporter) } +our @EXPORT = qw{ + ok is isnt like unlike is_deeply diag note skip_all todo plan done_testing + warnings exception tests capture +}; + +sub ok($;$@) { + my ($bool, $name, @diag) = @_; + my $ctx = context(); + $ctx->ok($bool, $name, \@diag); + $ctx->release; + return $bool ? 1 : 0; +} + +sub is($$;$@) { + my ($got, $want, $name, @diag) = @_; + my $ctx = context(); + + my $bool; + if (defined($got) && defined($want)) { + $bool = "$got" eq "$want"; + } + elsif (defined($got) xor defined($want)) { + $bool = 0; + } + else { # Both are undef + $bool = 1; + } + + unless ($bool) { + $got = '*NOT DEFINED*' unless defined $got; + $want = '*NOT DEFINED*' unless defined $want; + unshift @diag => ( + "GOT: $got", + "EXPECTED: $want", + ); + } + + $ctx->ok($bool, $name, \@diag); + $ctx->release; + return $bool; +} + +sub isnt($$;$@) { + my ($got, $want, $name, @diag) = @_; + my $ctx = context(); + + my $bool; + if (defined($got) && defined($want)) { + $bool = "$got" ne "$want"; + } + elsif (defined($got) xor defined($want)) { + $bool = 1; + } + else { # Both are undef + $bool = 0; + } + + unshift @diag => "Strings are the same (they should not be)" + unless $bool; + + $ctx->ok($bool, $name, \@diag); + $ctx->release; + return $bool; +} + +sub like($$;$@) { + my ($thing, $pattern, $name, @diag) = @_; + my $ctx = context(); + + my $bool; + if (defined($thing)) { + $bool = "$thing" =~ $pattern; + unshift @diag => ( + "Value: $thing", + "Does not match: $pattern" + ) unless $bool; + } + else { + $bool = 0; + unshift @diag => "Got an undefined value."; + } + + $ctx->ok($bool, $name, \@diag); + $ctx->release; + return $bool; +} + +sub unlike($$;$@) { + my ($thing, $pattern, $name, @diag) = @_; + my $ctx = context(); + + my $bool; + if (defined($thing)) { + $bool = "$thing" !~ $pattern; + unshift @diag => ( + "Unexpected pattern match (it should not match)", + "Value: $thing", + "Matches: $pattern" + ) unless $bool; + } + else { + $bool = 0; + unshift @diag => "Got an undefined value."; + } + + $ctx->ok($bool, $name, \@diag); + $ctx->release; + return $bool; +} + +sub is_deeply($$;$@) { + my ($got, $want, $name, @diag) = @_; + my $ctx = context(); + + no warnings 'once'; + require Data::Dumper; + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Deparse = 1; + local $Data::Dumper::Freezer = 'XXX'; + local *UNIVERSAL::XXX = sub { + my ($thing) = @_; + if (ref($thing)) { + $thing = {%$thing} if "$thing" =~ m/=HASH/; + $thing = [@$thing] if "$thing" =~ m/=ARRAY/; + $thing = \"$$thing" if "$thing" =~ m/=SCALAR/; + } + $_[0] = $thing; + }; + + my $g = Data::Dumper::Dumper($got); + my $w = Data::Dumper::Dumper($want); + + my $bool = $g eq $w; + + my $diff; + + $ctx->ok($bool, $name, [$diff ? $diff : ($g, $w), @diag]); + $ctx->release; + return $bool; +} + +sub diag { + my $ctx = context(); + $ctx->diag(join '', @_); + $ctx->release; +} + +sub note { + my $ctx = context(); + $ctx->note(join '', @_); + $ctx->release; +} + +sub skip_all { + my ($reason) = @_; + my $ctx = context(); + $ctx->plan(0, SKIP => $reason); + $ctx->release if $ctx; +} + +sub todo { + my ($reason, $sub) = @_; + my $ctx = context(); + + # This code is mostly copied from Test2::Todo in the Test2-Suite + # distribution. + my $hub = test2_stack->top; + my $filter = $hub->pre_filter( + sub { + my ($active_hub, $event) = @_; + + # Turn a diag into a note + return Test2::Event::Note->new(%$event) if ref($event) eq 'Test2::Event::Diag'; + + # Set todo on ok's + if ($hub == $active_hub && $event->isa('Test2::Event::Ok')) { + $event->set_todo($reason); + $event->set_effective_pass(1); + } + + return $event; + }, + inherit => 1, + todo => $reason, + ); + $sub->(); + $hub->pre_unfilter($filter); + + $ctx->release if $ctx; +} + +sub plan { + my ($max) = @_; + my $ctx = context(); + $ctx->plan($max); + $ctx->release; +} + +sub done_testing { + my $ctx = context(); + $ctx->done_testing; + $ctx->release; +} + +sub warnings(&) { + my $code = shift; + my @warnings; + local $SIG{__WARN__} = sub { push @warnings => @_ }; + $code->(); + return \@warnings; +} + +sub exception(&) { + my $code = shift; + local ($@, $!, $SIG{__DIE__}); + my $ok = eval { $code->(); 1 }; + my $error = $@ || 'SQUASHED ERROR'; + return $ok ? undef : $error; +} + +sub tests { + my ($name, $code) = @_; + my $ctx = context(); + + before_each() if __PACKAGE__->can('before_each'); + + my $bool = run_subtest($name, $code, 1); + + $ctx->release; + + return $bool; +} + +sub capture(&) { + my $code = shift; + + my ($err, $out) = ("", ""); + + my $handles = test2_stack->top->format->handles; + my ($ok, $e); + { + my ($out_fh, $err_fh); + + ($ok, $e) = try { + open($out_fh, '>', \$out) or die "Failed to open a temporary STDOUT: $!"; + open($err_fh, '>', \$err) or die "Failed to open a temporary STDERR: $!"; + + test2_stack->top->format->set_handles([$out_fh, $err_fh, $out_fh]); + + $code->(); + }; + } + test2_stack->top->format->set_handles($handles); + + die $e unless $ok; + + $err =~ s/ $/_/mg; + $out =~ s/ $/_/mg; + + return { + STDOUT => $out, + STDERR => $err, + }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::Tiny - Tiny set of tools for unfortunate souls who cannot use +L. + +=head1 DESCRIPTION + +You should really look at L. This package is some very basic +essential tools implemented using L. This exists only so that L +and other tools required by L can be tested. This is the package +L uses to test itself. + +=head1 USE Test2::Suite INSTEAD + +Use L if at all possible. + +=head1 EXPORTS + +=over 4 + +=item ok($bool, $name) + +=item ok($bool, $name, @diag) + +Run a simple assertion. + +=item is($got, $want, $name) + +=item is($got, $want, $name, @diag) + +Assert that 2 strings are the same. + +=item isnt($got, $do_not_want, $name) + +=item isnt($got, $do_not_want, $name, @diag) + +Assert that 2 strings are not the same. + +=item like($got, $regex, $name) + +=item like($got, $regex, $name, @diag) + +Check that the input string matches the regex. + +=item unlike($got, $regex, $name) + +=item unlike($got, $regex, $name, @diag) + +Check that the input string does not match the regex. + +=item is_deeply($got, $want, $name) + +=item is_deeply($got, $want, $name, @diag) + +Check 2 data structures. Please note that this is a I implementation that +compares the output of L against both structures. + +=item diag($msg) + +Issue a diagnostics message to STDERR. + +=item note($msg) + +Issue a diagnostics message to STDOUT. + +=item skip_all($reason) + +Skip all tests. + +=item todo $reason => sub { ... } + +Run a block in TODO mode. + +=item plan($count) + +Set the plan. + +=item done_testing() + +Set the plan to the current test count. + +=item $warnings = warnings { ... } + +Capture an arrayref of warnings from the block. + +=item $exception = exception { ... } + +Capture an exception. + +=item tests $name => sub { ... } + +Run a subtest. + +=item $output = capture { ... } + +Capture STDOUT and STDERR output. + +Result looks like this: + + { + STDOUT => "...", + STDERR => "...", + } + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Transition.pod b/Master/tlpkg/tlperl/lib/Test2/Transition.pod new file mode 100755 index 00000000000..95f9d77e9b1 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Transition.pod @@ -0,0 +1,512 @@ +=pod + +=head1 NAME + +Test2::Transition - Transition notes when upgrading to Test2 + +=head1 DESCRIPTION + +This is where gotchas and breakages related to the Test2 upgrade are +documented. The upgrade causes Test::Builder to defer to Test2 under the hood. +This transition is mostly transparent, but there are a few cases that can trip +you up. + +=head1 THINGS THAT BREAK + +This is the list of scenarios that break with the new internals. + +=head2 Test::Builder1.5/2 conditionals + +=head3 The Problem + +a few years back there were two attempts to upgrade/replace Test::Builder. +Confusingly these were called Test::Builder2 and Test::Builder1.5, in that +order. Many people put conditionals in their code to check the Test::Builder +version number and adapt their code accordingly. + +The Test::Builder2/1.5 projects both died out. Now the conditional code people +added has become a mine field. A vast majority of modules broken by Test2 fall +into this category. + +=head3 The Fix + +The fix is to remove all Test::Builder1.5/2 related code. Either use the +legacy Test::Builder API, or use Test2 directly. + +=head2 Replacing the Test::Builder singleton + +=head3 The Problem + +Some test modules would replace the Test::Builder singleton instance with their +own instance or subclass. This was usually done to intercept or modify results +as they happened. + +The Test::Builder singleton is now a simple compatibility wrapper around +Test2. The Test::Builder singleton is no longer the central place for +results. Many results bypass the Test::Builder singleton completely, which +breaks and behavior intended when replacing the singleton. + +=head3 The Fix + +If you simply want to intercept all results instead of letting them go to TAP, +you should look at the L docs and read about pushing a new hub onto +the hub stack. Replacing the hub temporarily is now the correct way to +intercept results. + +If your goal is purely monitoring of events use the C<< Test2::Hub->listen() >> +method exported by Test::More to watch events as they are fired. If you wish to +modify results before they go to TAP look at the C<< Test2::Hub->filter() >> +method. + +=head2 Directly Accessing Hash Elements + +=head3 The Problem + +Some modules look directly at hash keys on the Test::Builder singleton. The +problem here is that the Test::Builder singleton no longer holds anything +important. + +=head3 The Fix + +The fix is to use the API specified in L to look at or modify state +as needed. + +=head2 Subtest indentation + +=head3 The Problem + +An early change, in fact the change that made Test2 an idea, was a change to +the indentation of the subtest note. IT was decided it would be more readable +to outdent the subtest note instead of having it inline with the subtest: + + # subtest foo + ok 1 - blah + 1..1 + ok 1 - subtest foo + +The old style indented the note: + + # subtest foo + ok 1 - blah + 1..1 + ok 1 - subtest foo + +This breaks tests that do string comparison of TAP output. + +=head3 The Fix + + my $indent = $INC{'Test2/API.pm'} ? '' : ' '; + + is( + $subtest_output, + "${indent}# subtest foo", + "Got subtest note" + ); + +Check if C<$INC{'Test2/API.pm'}> is set, if it is then no indentation should be +expected. If it is not set than the old Test::Builder is in use, indentation +should be expected. + +=head1 DISTRIBUTIONS THAT BREAK OR NEED TO BE UPGRADED + +This is a list of cpan modules that have been known to have been broken by the +upgrade at one point. + +=head2 WORKS BUT TESTS WILL FAIL + +These modules still function correctly, but their test suites will not pass. If +you already have these modules installed then you can continue to use them. If +you are trying to install them after upgrading Test::Builder you will need to +force installation, or bypass the broken tests. + +=over 4 + +=item Test::DBIx::Class::Schema + +This module has a test that appears to work around a Test::Builder bug. The bug +appears to have been fixed by Test2, which means the workaround causes a +failure. This can be easily updated, but nobody has done so yet. + +Known broken in versions: 1.0.9 and older + +=item Test::Kit + +This actually works fine, but will not install because L is in +the dependency chain. + +See the L info below for additional information. + +=item Device::Chip + +Tests break due to subtest indentation. + +Known broken in version 0.07. Apparently works fine in 0.06 though. Patch has +been submitted to fix the issue. + +=back + +=head2 UPGRADE SUGGESTED + +These are modules that did not break, but had broken test suites that have +since been fixed. + +=over 4 + +=item Test::Exception + +Old versions work fine, but have a minor test name behavior that breaks with +Test2. Old versions will no longer install because of this. The latest version +on CPAN will install just fine. Upgrading is not required, but is recommended. + +Fixed in version: 0.43 + +=item Data::Peek + +Some tests depended on C<$!> and C<$?> being modified in subtle ways. A patch +was applied to correct things that changed. + +The module itself works fine, there is no need to upgrade. + +Fixed in version: 0.45 + +=item circular::require + +Some tests were fragile and required base.pm to be loaded at a late stage. +Test2 was loading base.pm too early. The tests were updated to fix this. + +The module itself never broke, you do not need to upgrade. + +Fixed in version: 0.12 + +=item Test::Module::Used + +A test worked around a now-fixed planning bug. There is no need to upgrade if +you have an old version installed. New versions install fine if you want them. + +Fixed in version: 0.2.5 + +=item Test::Moose::More + +Some tests were fragile, but have been fixed. The actual breakage was from the +subtest comment indentation change. + +No need to upgrade, old versions work fine. Only new versions will install. + +Fixed in version: 0.025 + +=item Test::FITesque + +This was broken by a bugfix to how planning is done. The test was updated after +the bugfix. + +Fixed in version: 0.04 + +=item autouse + +A test broke because it depended on Scalar::Util not being loaded. Test2 loads +Scalar::Util. The test was updated to load Test2 after checking Scalar::Util's +load status. + +There is no need to upgrade if you already have it installed. + +Fixed in version: 1.11 + +=back + +=head2 NEED TO UPGRADE + +=over 4 + +=item Test::SharedFork + +Old versions need to directly access Test::Builder singleton hash elements. The +latest version on CPAN will still do this on old Test::Builder, but will defer +to L on Test2. + +Fixed in version: 0.35 + +=item Test::Builder::Clutch + +This works by doing overriding methods on the singleton, and directly accessing +hash values on the singleton. A new version has been released that uses the +Test2 API to accomplish the same result in a saner way. + +Fixed in version: 0.07 + +=item Test::Dist::VersionSync + +This had Test::Builder2 conditionals. This was fixed by removing the +conditionals. + +Fixed in version: 1.1.4 + +=item Test::Modern + +This relied on C<< Test::Builder->_try() >> which was a private method, +documented as something nobody should use. This was fixed by using a different +tool. + +Fixed in version: 0.012 + +=item Test::UseAllModules + +Version 0.14 relied on C<< Test::Builder->history >> which was available in +Test::Builder 1.5. Versions 0.12 and 0.13 relied on other Test::Builder +internals. + +Fixed in version: 0.15 + +=back + +=head2 STILL BROKEN + +=over 4 + +=item Test::Aggregate + +This distribution directly accesses the hash keys in the L +singleton. It also approaches the problem from the wrong angle, please consider +using L or L which both solve the same problem +at the harness level. + +Still broken as of version: 0.373 + +=item Test::Wrapper + +This module directly uses hash keys in the L singleton. This +module is also obsolete thanks to the benefits of L. Use C +from L to achieve a similar result. + +Still broken as of version: 0.3.0 + +=item Test::ParallelSubtest + +This module overrides C and +C. It also directly accesses hash elements of +the singleton. It has not yet been fixed. + +Alternatives: L and L (not stable). + +Still broken as of version: 0.05 + +=item Test::Pretty + +See https://github.com/tokuhirom/Test-Pretty/issues/25 + +The author admits the module is crazy, and he is awaiting a stable release of +something new (Test2) to completely rewrite it in a sane way. + +Still broken as of version: 0.32 + +=item Test::More::Prefix + +The current version, 0.005 is broken. A patch has been applied in git, and +released in 0.006, but a version issue with 0.006 prevents its installation. + +Still broken as of version: 0.005 +Potentially fixed in version: 0.006 (not installable) + +=item Net::BitTorrent + +The tests for this module directly access L hash keys. Most, if +not all of these hash keys have public API methods that could be used instead +to avoid the problem. + +Still broken in version: 0.052 + +=item Test::Group + +It monkeypatches Test::Builder, and calls it "black magic" in the code. + +Still broken as of version: 0.20 + +=item Test::Flatten + +This modifies the Test::Builder internals in many ways. A better was to +accomplish the goal of this module is to write your own subtest function. + +Still broken as of version: 0.11 + +=item Log::Dispatch::Config::TestLog + +Modifies Test::Builder internals. + +Still broken as of version: 0.02 + +=item Test::Able + +Modifies Test::Builder internals. + +Still broken as of version: 0.11 + +=back + +=head1 MAKE ASSERTIONS -> SEND EVENTS + +=head2 LEGACY + + use Test::Builder; + + # A majority of tools out there do this: + # my $TB = Test::Builder->new; + # This works, but has always been wrong, forcing Test::Builder to implement + # subtests as a horrific hack. It also causes problems for tools that try + # to replace the singleton (also discouraged). + + sub my_ok($;$) { + my ($bool, $name) = @_; + my $TB = Test::Builder->new; + $TB->ok($bool, $name); + } + + sub my_diag($) { + my ($msg) = @_; + my $TB = Test::Builder->new; + $TB->diag($msg); + } + +=head2 TEST2 + + use Test2::API qw/context/; + + sub my_ok($;$) { + my ($bool, $name) = @_; + my $ctx = context(); + $ctx->ok($bool, $name); + $ctx->release; + } + + sub my_diag($) { + my ($msg) = @_; + my $ctx = context(); + $ctx->diag($msg); + $ctx->release; + } + +The context object has API compatible implementations of the following methods: + +=over 4 + +=item ok($bool, $name) + +=item diag(@messages) + +=item note(@messages) + +=item subtest($name, $code) + +=back + +If you are looking for helpers with C, C, and others, see +L. + +=head1 WRAP EXISTING TOOLS + +=head2 LEGACY + + use Test::More; + + sub exclusive_ok { + my ($bool1, $bool2, $name) = @_; + + # Ensure errors are reported 1 level higher + local $Test::Builder::Level = $Test::Builder::Level + 1; + + $ok = $bool1 || $bool2; + $ok &&= !($bool1 && $bool2); + ok($ok, $name); + + return $bool; + } + +Every single tool in the chain from this, to C, to anything C calls +needs to increment the C<$Level> variable. When an error occurs Test::Builder +will do a trace to the stack frame determined by C<$Level>, and report that +file+line as the one where the error occurred. If you or any other tool you use +forgets to set C<$Level> then errors will be reported to the wrong place. + +=head2 TEST2 + + use Test::More; + + sub exclusive_ok { + my ($bool1, $bool2, $name) = @_; + + # Grab and store the context, even if you do not need to use it + # directly. + my $ctx = context(); + + $ok = $bool1 || $bool2; + $ok &&= !($bool1 && $bool2); + ok($ok, $name); + + $ctx->release; + return $bool; + } + +Instead of using C<$Level> to perform a backtrace, Test2 uses a context +object. In this sample you create a context object and store it. This locks the +context (errors report 1 level up from here) for all wrapped tools to find. You +do not need to use the context object, but you do need to store it in a +variable. Once the sub ends the C<$ctx> variable is destroyed which lets future +tools find their own. + +=head1 USING UTF8 + +=head2 LEGACY + + # Set the mode BEFORE anything loads Test::Builder + use open ':std', ':encoding(utf8)'; + use Test::More; + +Or + + # Modify the filehandles + my $builder = Test::More->builder; + binmode $builder->output, ":encoding(utf8)"; + binmode $builder->failure_output, ":encoding(utf8)"; + binmode $builder->todo_output, ":encoding(utf8)"; + +=head2 TEST2 + + use Test2::API qw/test2_stack/; + + test2_stack->top->format->encoding('utf8'); + +Though a much better way is to use the L plugin, which is +part of L. + +=head1 AUTHORS, CONTRIBUTORS AND REVIEWERS + +The following people have all contributed to this document in some way, even if +only for review. + +=over 4 + +=item Chad Granum (EXODIST) Eexodist@cpan.orgE + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Util.pm b/Master/tlpkg/tlperl/lib/Test2/Util.pm new file mode 100755 index 00000000000..53379d41dde --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Util.pm @@ -0,0 +1,258 @@ +package Test2::Util; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +use Config qw/%Config/; + +our @EXPORT_OK = qw{ + try + + pkg_to_file + + get_tid USE_THREADS + CAN_THREAD + CAN_REALLY_FORK + CAN_FORK + + IS_WIN32 + + ipc_separator +}; +BEGIN { require Exporter; our @ISA = qw(Exporter) } + +BEGIN { + *IS_WIN32 = ($^O eq 'MSWin32') ? sub() { 1 } : sub() { 0 }; +} + +sub _can_thread { + return 0 unless $] >= 5.008001; + return 0 unless $Config{'useithreads'}; + + # Threads are broken on perl 5.10.0 built with gcc 4.8+ + if ($] == 5.010000 && $Config{'ccname'} eq 'gcc' && $Config{'gccversion'}) { + my @parts = split /\./, $Config{'gccversion'}; + return 0 if $parts[0] > 4 || ($parts[0] == 4 && $parts[1] >= 8); + } + + # Change to a version check if this ever changes + return 0 if $INC{'Devel/Cover.pm'}; + return 1; +} + +sub _can_fork { + return 1 if $Config{d_fork}; + return 0 unless IS_WIN32 || $^O eq 'NetWare'; + return 0 unless $Config{useithreads}; + return 0 unless $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/; + + return _can_thread(); +} + +BEGIN { + no warnings 'once'; + *CAN_THREAD = _can_thread() ? sub() { 1 } : sub() { 0 }; +} +my $can_fork; +sub CAN_FORK () { + return $can_fork + if defined $can_fork; + $can_fork = !!_can_fork(); + no warnings 'redefine'; + *CAN_FORK = $can_fork ? sub() { 1 } : sub() { 0 }; + $can_fork; +} +my $can_really_fork; +sub CAN_REALLY_FORK () { + return $can_really_fork + if defined $can_really_fork; + $can_really_fork = !!$Config{d_fork}; + no warnings 'redefine'; + *CAN_REALLY_FORK = $can_really_fork ? sub() { 1 } : sub() { 0 }; + $can_really_fork; +} + +sub _manual_try(&;@) { + my $code = shift; + my $args = \@_; + my $err; + + my $die = delete $SIG{__DIE__}; + + eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n"; + + $die ? $SIG{__DIE__} = $die : delete $SIG{__DIE__}; + + return (!defined($err), $err); +} + +sub _local_try(&;@) { + my $code = shift; + my $args = \@_; + my $err; + + no warnings; + local $SIG{__DIE__}; + eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n"; + + return (!defined($err), $err); +} + +# Older versions of perl have a nasty bug on win32 when localizing a variable +# before forking or starting a new thread. So for those systems we use the +# non-local form. When possible though we use the faster 'local' form. +BEGIN { + if (IS_WIN32 && $] < 5.020002) { + *try = \&_manual_try; + } + else { + *try = \&_local_try; + } +} + +BEGIN { + if (CAN_THREAD) { + if ($INC{'threads.pm'}) { + # Threads are already loaded, so we do not need to check if they + # are loaded each time + *USE_THREADS = sub() { 1 }; + *get_tid = sub() { threads->tid() }; + } + else { + # :-( Need to check each time to see if they have been loaded. + *USE_THREADS = sub() { $INC{'threads.pm'} ? 1 : 0 }; + *get_tid = sub() { $INC{'threads.pm'} ? threads->tid() : 0 }; + } + } + else { + # No threads, not now, not ever! + *USE_THREADS = sub() { 0 }; + *get_tid = sub() { 0 }; + } +} + +sub pkg_to_file { + my $pkg = shift; + my $file = $pkg; + $file =~ s{(::|')}{/}g; + $file .= '.pm'; + return $file; +} + +sub ipc_separator() { "~" } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util - Tools used by Test2 and friends. + +=head1 DESCRIPTION + +Collection of tools used by L and friends. + +=head1 EXPORTS + +All exports are optional. You must specify subs to import. + +=over 4 + +=item ($success, $error) = try { ... } + +Eval the codeblock, return success or failure, and the error message. This code +protects $@ and $!, they will be restored by the end of the run. This code also +temporarily blocks $SIG{DIE} handlers. + +=item protect { ... } + +Similar to try, except that it does not catch exceptions. The idea here is to +protect $@ and $! from changes. $@ and $! will be restored to whatever they +were before the run so long as it is successful. If the run fails $! will still +be restored, but $@ will contain the exception being thrown. + +=item CAN_FORK + +True if this system is capable of true or pseudo-fork. + +=item CAN_REALLY_FORK + +True if the system can really fork. This will be false for systems where fork +is emulated. + +=item CAN_THREAD + +True if this system is capable of using threads. + +=item USE_THREADS + +Returns true if threads are enabled, false if they are not. + +=item get_tid + +This will return the id of the current thread when threads are enabled, +otherwise it returns 0. + +=item my $file = pkg_to_file($package) + +Convert a package name to a filename. + +=back + +=head1 NOTES && CAVEATS + +=over 4 + +=item 5.10.0 + +Perl 5.10.0 has a bug when compiled with newer gcc versions. This bug causes a +segfault whenever a new thread is launched. Test2 will attempt to detect +this, and note that the system is not capable of forking when it is detected. + +=item Devel::Cover + +Devel::Cover does not support threads. CAN_THREAD will return false if +Devel::Cover is loaded before the check is first run. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=item Kent Fredric Ekentnl@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Util/ExternalMeta.pm b/Master/tlpkg/tlperl/lib/Test2/Util/ExternalMeta.pm new file mode 100755 index 00000000000..f9c611e0f25 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Util/ExternalMeta.pm @@ -0,0 +1,182 @@ +package Test2::Util::ExternalMeta; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +use Carp qw/croak/; + +sub META_KEY() { '_meta' } + +our @EXPORT = qw/meta set_meta get_meta delete_meta/; +BEGIN { require Exporter; our @ISA = qw(Exporter) } + +sub set_meta { + my $self = shift; + my ($key, $value) = @_; + + validate_key($key); + + $self->{+META_KEY} ||= {}; + $self->{+META_KEY}->{$key} = $value; +} + +sub get_meta { + my $self = shift; + my ($key) = @_; + + validate_key($key); + + my $meta = $self->{+META_KEY} or return undef; + return $meta->{$key}; +} + +sub delete_meta { + my $self = shift; + my ($key) = @_; + + validate_key($key); + + my $meta = $self->{+META_KEY} or return undef; + delete $meta->{$key}; +} + +sub meta { + my $self = shift; + my ($key, $default) = @_; + + validate_key($key); + + my $meta = $self->{+META_KEY}; + return undef unless $meta || defined($default); + + unless($meta) { + $meta = {}; + $self->{+META_KEY} = $meta; + } + + $meta->{$key} = $default + if defined($default) && !defined($meta->{$key}); + + return $meta->{$key}; +} + +sub validate_key { + my $key = shift; + + return if $key && !ref($key); + + my $render_key = defined($key) ? "'$key'" : 'undef'; + croak "Invalid META key: $render_key, keys must be true, and may not be references"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util::ExternalMeta - Allow third party tools to safely attach meta-data +to your instances. + +=head1 DESCRIPTION + +This package lets you define a clear, and consistent way to allow third party +tools to attach meta-data to your instances. If your object consumes this +package, and imports its methods, then third party meta-data has a safe place +to live. + +=head1 SYNOPSIS + + package My::Object; + use strict; + use warnings; + + use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; + + ... + +Now to use it: + + my $inst = My::Object->new; + + $inst->set_meta(foo => 'bar'); + my $val = $inst->get_meta('foo'); + +=head1 WHERE IS THE DATA STORED? + +This package assumes your instances are blessed hashrefs, it will not work if +that is not true. It will store all meta-data in the C<_meta> key on your +objects hash. If your object makes use of the C<_meta> key in its underlying +hash, then there is a conflict and you cannot use this package. + +=head1 EXPORTS + +=over 4 + +=item $val = $obj->meta($key) + +=item $val = $obj->meta($key, $default) + +This will get the value for a specified meta C<$key>. Normally this will return +C when there is no value for the C<$key>, however you can specify a +C<$default> value to set when no value is already set. + +=item $val = $obj->get_meta($key) + +This will get the value for a specified meta C<$key>. This does not have the +C<$default> overhead that C does. + +=item $val = $obj->delete_meta($key) + +This will remove the value of a specified meta C<$key>. The old C<$val> will be +returned. + +=item $obj->set_meta($key, $val) + +Set the value of a specified meta C<$key>. + +=back + +=head1 META-KEY RESTRICTIONS + +Meta keys must be defined, and must be true when used as a boolean. Keys may +not be references. You are free to stringify a reference C<"$ref"> for use as a +key, but this package will not stringify it for you. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Util/HashBase.pm b/Master/tlpkg/tlperl/lib/Test2/Util/HashBase.pm new file mode 100755 index 00000000000..76041efe5ee --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Util/HashBase.pm @@ -0,0 +1,289 @@ +package Test2::Util::HashBase; +use strict; +use warnings; + +################################################################# +# # +# This is a generated file! Do not modify this file directly! # +# Use hashbase_inc.pl script to regenerate this file. # +# The script is part of the Object::HashBase distribution. # +# # +################################################################# + +{ + no warnings 'once'; + $Test2::Util::HashBase::VERSION = '0.002'; + *Test2::Util::HashBase::ATTR_SUBS = \%Object::HashBase::ATTR_SUBS; +} + + +require Carp; +{ + no warnings 'once'; + $Carp::Internal{+__PACKAGE__} = 1; +} + +BEGIN { + # these are not strictly equivalent, but for out use we don't care + # about order + *_isa = ($] >= 5.010 && require mro) ? \&mro::get_linear_isa : sub { + no strict 'refs'; + my @packages = ($_[0]); + my %seen; + for my $package (@packages) { + push @packages, grep !$seen{$_}++, @{"$package\::ISA"}; + } + return \@packages; + } +} + +my %STRIP = ( + '^' => 1, + '-' => 1, +); + +sub import { + my $class = shift; + my $into = caller; + + my $isa = _isa($into); + my $attr_subs = $Test2::Util::HashBase::ATTR_SUBS{$into} ||= {}; + my %subs = ( + ($into->can('new') ? () : (new => \&_new)), + (map %{$Test2::Util::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]), + ( + map { + my $p = substr($_, 0, 1); + my $x = $_; + substr($x, 0, 1) = '' if $STRIP{$p}; + my ($sub, $attr) = (uc $x, $x); + $sub => ($attr_subs->{$sub} = sub() { $attr }), + $attr => sub { $_[0]->{$attr} }, + $p eq '-' ? ("set_$attr" => sub { Carp::croak("'$attr' is read-only") }) + : $p eq '^' ? ("set_$attr" => sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] }) + : ("set_$attr" => sub { $_[0]->{$attr} = $_[1] }), + } @_ + ), + ); + + no strict 'refs'; + *{"$into\::$_"} = $subs{$_} for keys %subs; +} + +sub _new { + my ($class, %params) = @_; + my $self = bless \%params, $class; + $self->init if $self->can('init'); + $self; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util::HashBase - Build hash based classes. + +=head1 SYNOPSIS + +A class: + + package My::Class; + use strict; + use warnings; + + # Generate 3 accessors + use Test2::Util::HashBase qw/foo -bar ^baz/; + + # Chance to initialize defaults + sub init { + my $self = shift; # No other args + $self->{+FOO} ||= "foo"; + $self->{+BAR} ||= "bar"; + $self->{+BAZ} ||= "baz"; + } + + sub print { + print join ", " => map { $self->{$_} } FOO, BAR, BAZ; + } + +Subclass it + + package My::Subclass; + use strict; + use warnings; + + # Note, you should subclass before loading HashBase. + use base 'My::Class'; + use Test2::Util::HashBase qw/bat/; + + sub init { + my $self = shift; + + # We get the constants from the base class for free. + $self->{+FOO} ||= 'SubFoo'; + $self->{+BAT} ||= 'bat'; + + $self->SUPER::init(); + } + +use it: + + package main; + use strict; + use warnings; + use My::Class; + + my $one = My::Class->new(foo => 'MyFoo', bar => 'MyBar'); + + # Accessors! + my $foo = $one->foo; # 'MyFoo' + my $bar = $one->bar; # 'MyBar' + my $baz = $one->baz; # Defaulted to: 'baz' + + # Setters! + $one->set_foo('A Foo'); + + #'-bar' means read-only, so the setter will throw an exception (but is defined). + $one->set_bar('A bar'); + + # '^baz' means deprecated setter, this will warn about the setter being + # deprecated. + $one->set_baz('A Baz'); + + $one->{+FOO} = 'xxx'; + +=head1 DESCRIPTION + +This package is used to generate classes based on hashrefs. Using this class +will give you a C method, as well as generating accessors you request. +Generated accessors will be getters, C setters will also be +generated for you. You also get constants for each accessor (all caps) which +return the key into the hash for that accessor. Single inheritance is also +supported. + +=head1 THIS IS A BUNDLED COPY OF HASHBASE + +This is a bundled copy of L. This file was generated using +the +C +script. + +=head1 METHODS + +=head2 PROVIDED BY HASH BASE + +=over 4 + +=item $it = $class->new(@VALUES) + +Create a new instance using key/value pairs. + +HashBase will not export C if there is already a C method in your +packages inheritance chain. + +B you just have to +declare it before loading L. + + package My::Package; + + # predeclare new() so that HashBase does not give us one. + sub new; + + use Test2::Util::HashBase qw/foo bar baz/; + + # Now we define our own new method. + sub new { ... } + +This makes it so that HashBase sees that you have your own C method. +Alternatively you can define the method before loading HashBase instead of just +declaring it, but that scatters your use statements. + +=back + +=head2 HOOKS + +=over 4 + +=item $self->init() + +This gives you the chance to set some default values to your fields. The only +argument is C<$self> with its indexes already set from the constructor. + +=back + +=head1 ACCESSORS + +To generate accessors you list them when using the module: + + use Test2::Util::HashBase qw/foo/; + +This will generate the following subs in your namespace: + +=over 4 + +=item foo() + +Getter, used to get the value of the C field. + +=item set_foo() + +Setter, used to set the value of the C field. + +=item FOO() + +Constant, returns the field C's key into the class hashref. Subclasses will +also get this function as a constant, not simply a method, that means it is +copied into the subclass namespace. + +The main reason for using these constants is to help avoid spelling mistakes +and similar typos. It will not help you if you forget to prefix the '+' though. + +=back + +=head1 SUBCLASSING + +You can subclass an existing HashBase class. + + use base 'Another::HashBase::Class'; + use Test2::Util::HashBase qw/foo bar baz/; + +The base class is added to C<@ISA> for you, and all constants from base classes +are added to subclasses automatically. + +=head1 SOURCE + +The source code repository for HashBase can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/Master/tlpkg/tlperl/lib/Test2/Util/Trace.pm b/Master/tlpkg/tlperl/lib/Test2/Util/Trace.pm new file mode 100755 index 00000000000..0f10bcb6ad3 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Util/Trace.pm @@ -0,0 +1,186 @@ +package Test2::Util::Trace; +use strict; +use warnings; + +our $VERSION = '1.302073'; + + +use Test2::Util qw/get_tid pkg_to_file/; + +use Carp qw/confess/; + +use Test2::Util::HashBase qw{frame detail pid tid}; + +sub init { + confess "The 'frame' attribute is required" + unless $_[0]->{+FRAME}; + + $_[0]->{+PID} = $$ unless defined $_[0]->{+PID}; + $_[0]->{+TID} = get_tid() unless defined $_[0]->{+TID}; +} + +sub snapshot { bless {%{$_[0]}}, __PACKAGE__ }; + +sub debug { + my $self = shift; + return $self->{+DETAIL} if $self->{+DETAIL}; + my ($pkg, $file, $line) = $self->call; + return "at $file line $line"; +} + +sub alert { + my $self = shift; + my ($msg) = @_; + warn $msg . ' ' . $self->debug . ".\n"; +} + +sub throw { + my $self = shift; + my ($msg) = @_; + die $msg . ' ' . $self->debug . ".\n"; +} + +sub call { @{$_[0]->{+FRAME}} } + +sub package { $_[0]->{+FRAME}->[0] } +sub file { $_[0]->{+FRAME}->[1] } +sub line { $_[0]->{+FRAME}->[2] } +sub subname { $_[0]->{+FRAME}->[3] } + +sub from_json { + my $class = shift; + my %p = @_; + + my $trace_pkg = delete $p{__PACKAGE__}; + require(pkg_to_file($trace_pkg)); + + return $trace_pkg->new(%p); +} + +sub TO_JSON { + my $self = shift; + return {%$self, __PACKAGE__ => ref $self}; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util::Trace - Debug information for events + +=head1 DESCRIPTION + +The L object, as well as all L types need to +have access to information about where they were created. This object +represents that information. + +=head1 SYNOPSIS + + use Test2::Util::Trace; + + my $trace = Test2::Util::Trace->new( + frame => [$package, $file, $line, $subname], + ); + +=head1 METHODS + +=over 4 + +=item $trace->set_detail($msg) + +=item $msg = $trace->detail + +Used to get/set a custom trace message that will be used INSTEAD of +C<< at line >> when calling C<< $trace->debug >>. + +=item $str = $trace->debug + +Typically returns the string C<< at line >>. If C is set +then its value will be returned instead. + +=item $trace->alert($MESSAGE) + +This issues a warning at the frame (filename and line number where +errors should be reported). + +=item $trace->throw($MESSAGE) + +This throws an exception at the frame (filename and line number where +errors should be reported). + +=item $frame = $trace->frame() + +Get the call frame arrayref. + +=item ($package, $file, $line, $subname) = $trace->call() + +Get the caller details for the debug-info. This is where errors should be +reported. + +=item $pkg = $trace->package + +Get the debug-info package. + +=item $file = $trace->file + +Get the debug-info filename. + +=item $line = $trace->line + +Get the debug-info line number. + +=item $subname = $trace->subname + +Get the debug-info subroutine name. + +=item $hashref = $t->TO_JSON + +This returns a hashref suitable for passing to the C<< +Test2::Util::Trace->from_json >> constructor. It is intended for use with the +L family of modules, which will look for a C method when +C is true. + +=item $t = Test2::Util::Trace->from_json(%$hashref) + +Given the hash of data returned by C<< $t->TO_JSON >>, this method returns a +new trace object of the appropriate subclass. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut -- cgit v1.2.3