diff options
author | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
---|---|---|
committer | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
commit | e0c6872cf40896c7be36b11dcc744620f10adf1d (patch) | |
tree | 60335e10d2f4354b0674ec22d7b53f0f8abee672 /systems/texlive/tlnet/tlpkg/tlperl/lib/Test2 |
Initial commit
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/Test2')
50 files changed, 13234 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API.pm new file mode 100644 index 0000000000..f5caaa6947 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API.pm @@ -0,0 +1,1567 @@ +package Test2::API; +use strict; +use warnings; + +use Test2::Util qw/USE_THREADS/; + +BEGIN { + $ENV{TEST_ACTIVE} ||= 1; + $ENV{TEST2_ACTIVE} = 1; +} + +our $VERSION = '1.302133'; + + +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(); +} + +sub CLONE { + my $init = test2_init_done(); + my $load = test2_load_done(); + + return if $init && $load; + + require Carp; + Carp::croak "Test2 must be fully loaded before you start a new thread!\n"; +} + +# 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::EventFacet::Trace(); +use Test2::Util::Trace(); # Legacy + +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/; +use Scalar::Util qw/blessed weaken/; +use Test2::Util qw/get_tid clone_io pkg_to_file/; + +our @EXPORT_OK = qw{ + context release + context_do + no_context + intercept intercept_deep + run_subtest + + test2_init_done + test2_load_done + test2_load + test2_start_preload + test2_stop_preload + test2_in_preload + + test2_set_is_end + test2_get_is_end + + test2_pid + test2_tid + test2_stack + test2_no_wait + test2_ipc_wait_enable + test2_ipc_wait_disable + test2_ipc_wait_enabled + + test2_add_uuid_via + + 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_add_callback_pre_subtest + 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_list_pre_subtest_callbacks + + test2_ipc + test2_has_ipc + test2_ipc_disable + test2_ipc_disabled + 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_get_timeout + test2_ipc_set_timeout + test2_ipc_enable_shm + + test2_formatter + test2_formatters + test2_formatter_add + test2_formatter_set + + test2_stdout + test2_stderr + test2_reset_io +}; +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; + +my $STDOUT = clone_io(\*STDOUT); +my $STDERR = clone_io(\*STDERR); +sub test2_stdout { $STDOUT ||= clone_io(\*STDOUT) } +sub test2_stderr { $STDERR ||= clone_io(\*STDERR) } + +sub test2_post_preload_reset { + test2_reset_io(); + $INST->post_preload_reset; +} + +sub test2_reset_io { + $STDOUT = clone_io(\*STDOUT); + $STDERR = clone_io(\*STDERR); +} + +sub test2_init_done { $INST->finalized } +sub test2_load_done { $INST->loaded } + +sub test2_load { $INST->load } +sub test2_start_preload { $ENV{T2_IN_PRELOAD} = 1; $INST->start_preload } +sub test2_stop_preload { $ENV{T2_IN_PRELOAD} = 0; $INST->stop_preload } +sub test2_in_preload { $INST->preload } + +sub test2_pid { $INST->pid } +sub test2_tid { $INST->tid } +sub test2_stack { $INST->stack } +sub test2_ipc_wait_enable { $INST->set_no_wait(0) } +sub test2_ipc_wait_disable { $INST->set_no_wait(1) } +sub test2_ipc_wait_enabled { !$INST->no_wait } + +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_add_callback_pre_subtest { $INST->add_pre_subtest_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_list_pre_subtest_callbacks { @{$INST->pre_subtest_callbacks} } + +sub test2_add_uuid_via { + $INST->set_add_uuid_via(@_) if @_; + $INST->add_uuid_via(); +} + +sub test2_ipc { $INST->ipc } +sub test2_has_ipc { $INST->has_ipc } +sub test2_ipc_disable { $INST->ipc_disable } +sub test2_ipc_disabled { $INST->ipc_disabled } +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_set_timeout { $INST->set_ipc_timeout(@_) } +sub test2_ipc_get_timeout { $INST->ipc_timeout() } +sub test2_ipc_enable_shm { $INST->ipc_enable_shm } + +sub test2_formatter { + if ($ENV{T2_FORMATTER} && $ENV{T2_FORMATTER} =~ m/^(\+)?(.*)$/) { + my $formatter = $1 ? $2 : "Test2::Formatter::$2"; + my $file = pkg_to_file($formatter); + require $file; + return $formatter; + } + + return $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 } +sub _add_uuid_via_ref { \($INST->{Test2::API::Instance::ADD_UUID_VIA()}) } + +# 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; +}; + +my $UUID_VIA = _add_uuid_via_ref(); +my $CID = 1; +sub context { + # We need to grab these before anything else to ensure they are not + # changed. + my ($errno, $eval_error, $child_error, $extended_error) = (0 + $!, $@, $?, $^E); + + 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.... + ($!, $@, $?, $^E) = ($errno, $eval_error, $child_error, $extended_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(), + cid => 'C' . $CID++, + hid => $hid, + nested => $hub->{nested}, + buffered => $hub->{buffered}, + + $$UUID_VIA ? ( + huuid => $hub->{uuid}, + uuid => ${$UUID_VIA}->('context'), + ) : (), + }, + 'Test2::EventFacet::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}; + + ($!, $@, $?, $^E) = ($errno, $eval_error, $child_error, $extended_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}; + + # Older versions of Carp do not export longmess() function, so it needs to be called with package name + my $mess = Carp::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 $events = _intercept($code, deep => 0); + + $ctx->release; + + return $events; +} + +sub intercept_deep(&) { + my $code = shift; + my $ctx = context(); + + my $events = _intercept($code, deep => 1); + + $ctx->release; + + return $events; +} + +sub _intercept { + my $code = shift; + my %params = @_; + 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] }, inherit => $params{deep}); + + $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) = @_; + + $_->($name,$code,@args) + for Test2::API::test2_list_pre_subtest_callbacks(); + + $params = {buffered => $params} unless ref $params; + my $inherit_trace = delete $params->{inherit_trace}; + + my $ctx = context(); + + my $parent = $ctx->hub; + + # If a parent is buffered then the child must be as well. + my $buffered = $params->{buffered} || $parent->{buffered}; + + $ctx->note($name) unless $buffered; + + my $stack = $ctx->stack || $STACK; + my $hub = $stack->new_hub( + class => 'Test2::Hub::Subtest', + %$params, + buffered => $buffered, + ); + + my @events; + $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; + } + } + + if ($inherit_trace) { + my $orig = $code; + $code = sub { + my $base_trace = $ctx->trace; + my $trace = $base_trace->snapshot(nested => 1 + $base_trace->nested); + my $st_ctx = Test2::API::Context->new( + trace => $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; + } + } + + if ($params->{no_fork}) { + if ($$ != $ctx->trace->pid) { + warn $ok ? "Forked inside subtest, but subtest never finished!\n" : $err; + exit 255; + } + + if (get_tid() != $ctx->trace->tid) { + warn $ok ? "Started new thread inside subtest, but thread never finished!\n" : $err; + exit 255; + } + } + elsif (!$parent->is_local && !$parent->ipc) { + warn $ok ? "A new process or thread was started inside subtest, but IPC is not enabled!\n" : $err; + exit 255; + } + + $stack->pop($hub); + + my $trace = $ctx->trace; + + my $bailed = $hub->bailed_out; + + if (!$finished) { + if ($bailed && !$buffered) { + $ctx->bail($bailed->reason); + } + elsif ($bailed && $buffered) { + $ok = 1; + } + else { + my $code = $hub->exit_code; + $ok = !$code; + $err = "Subtest ended with exit code $code" if $code; + } + } + + $hub->finalize($trace->snapshot(huuid => $hub->uuid, hid => $hub->hid, nested => $hub->nested, buffered => $buffered), 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, + subtest_uuid => $hub->uuid, + 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->bail($bailed->reason) if $bailed && $buffered; + + $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 internals of this package are subject to change at any time!> The public +methods provided will not change in backwards-incompatible ways (once there is +a stable release), but the underlying implementation details might. +B<Do not break encapsulation here!> + +Currently the implementation is to create a single instance of the +L<Test2::API::Instance> 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<context()> 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<Test2::API::Context> for a list of methods available on the context object. + +=head2 TESTING YOUR TOOLS + +The C<intercept { ... }> 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"); + +=head3 DEEP EVENT INTERCEPTION + +Normally C<intercept { ... }> only intercepts events sent to the main hub (as +added by intercept itself). Nested hubs, such as those created by subtests, +will not be intercepted. This is normally what you will still see the nested +events by inspecting the subtest event. However there are times where you want +to verify each event as it is sent, in that case use C<intercept_deep { ... }>. + + my $events = intercept_Deep { + buffered_subtest foo => sub { + ok(1, "pass"); + }; + }; + +C<$events> in this case will contain 3 items: + +=over 4 + +=item The event from C<ok(1, "pass")> + +=item The plan event for the subtest + +=item The subtest event itself, with the first 2 events nested inside it as children. + +=back + +This lets you see the order in which the events were sent, unlike +C<intercept { ... }> which only lets you see events as the main hub sees them. + +=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</OTHER API EXPORTS>. + +These exports lack the 'test2_' prefix because of how important/common they +are. Exports in the L</OTHER API EXPORTS> 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<context()> 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<Test2::API::Context/"CRITICAL DETAILS"> for important rules about +what you can and cannot do with a context once it is obtained. + +B<Note> This function will throw an exception if you ignore the context object +it returns. + +B<Note> 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<https://rt.perl.org/Public/Bug/Display.html?id=127774> +You can forcefully enable it either by setting C<$ENV{T2_CHECK_DEPTH} = 1> or +C<$Test2::API::DO_DEPTH_CHECK = 1> B<BEFORE> loading L<Test2::API>. + +=head3 OPTIONAL PARAMETERS + +All parameters to C<context> 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<context()> +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<context()> looks at the global hub stack. If you are maintaining +your own L<Test2::API::Stack> 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<ONLY> if your call +to C<context()> generated a new context. The callback B<WILL NOT> be called if +C<context()> 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<Test2::Event>. + +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<Test2::Event::Subtest> 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. + +=item 'no_fork' => $bool + +Defaults to off. Normally forking inside a subtest will actually fork the +subtest, resulting in 2 final subtest events. This parameter will turn off that +behavior, only the original process/thread will return a final subtest event. + +=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<subevents> attribute on the +L<Test2::Event::Subtest> 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<Test2::Event::Subtest> event is sent to +the formatter. + +=item Things that are effected by this flag + +The C<buffered> attribute of the L<Test2::Event::Subtest> 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<NOT SEND> +the events as they are generated, instead the formatter can pull them from the +C<subevents> attribute. + +A formatter can specify by implementing the C<hide_buffered()> 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<Test2::Formatter::TAP> 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<subevents> +attribute is ignored. For buffered subtests the opposite occurs, the events are +NOT rendered as they are generated, instead the C<subevents> 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</MAIN API +EXPORTS> 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<caller()> 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<Test2::API::Stack> instance. If this has not +yet been initialized it will be initialized now. + +=item test2_ipc_disable + +Disable IPC. + +=item $bool = test2_ipc_diabled + +Check if IPC is disabled. + +=item test2_ipc_wait_enable() + +=item test2_ipc_wait_disable() + +=item $bool = test2_ipc_wait_enabled() + +These can be used to turn IPC waiting on and off, or check the current value of +the flag. + +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. + +=item $bool = test2_no_wait() + +=item test2_no_wait($bool) + +B<DISCOURAGED>: This is a confusing interface, it is better to use +C<test2_ipc_wait_enable()>, C<test2_ipc_wait_disable()> and +C<test2_ipc_wait_enabled()>. + +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. + +=item $fh = test2_stdout() + +=item $fh = test2_stderr() + +These functions return the filehandles that test output should be written to. +They are primarily useful when writing a custom formatter and code that turns +events into actual output (TAP, etc.) They will return a dupe of the original +filehandles that formatted output can be sent to regardless of whatever state +the currently running test may have left STDOUT and STDERR in. + +=item test2_reset_io() + +Re-dupe the internal filehandles returned by C<test2_stdout()> and +C<test2_stderr()> from the current STDOUT and STDERR. You shouldn't need to do +this except in very peculiar situations (for example, you're testing a new +formatter and you need control over where the formatter is sending its output.) + +=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<Test2::API::Context>. 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<context()>. 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<Test::Builder> 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 test2_add_callback_pre_subtest(sub { ... }) + +Add a callback that will be called every time a subtest is going to be +run. The callback will receive the subtest name, coderef, and any +arguments. + +=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. + +=item @list = test2_list_pre_subtest_callbacks() + +Returns all the pre-subtest callback references. + +=item test2_add_uuid_via(sub { ... }) + +=item $sub = test2_add_uuid_via() + +This allows you to provide a UUID generator. If provided UUIDs will be attached +to all events, hubs, and contexts. This is useful for storing, tracking, and +linking these objects. + +The sub you provide should always return a unique identifier. Most things will +expect a proper UUID string, however nothing in Test2::API enforces this. + +The sub will receive exactly 1 argument, the type of thing being tagged +'context', 'hub', or 'event'. In the future additional things may be tagged, in +which case new strings will be passed in. These are purely informative, you can +(and usually should) ignore them. + +=back + +=head2 IPC AND CONCURRENCY + +These let you access, or specify, the IPC system internals. + +=over 4 + +=item $bool = test2_has_ipc() + +Check if IPC is enabled. + +=item $ipc = test2_ipc() + +This will return the global L<Test2::IPC::Driver> 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<Note:> After calling this C<test2_ipc_get_pending()> 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. + +=item $timeout = test2_ipc_get_timeout() + +=item test2_ipc_set_timeout($timeout) + +Get/Set the timeout value for the IPC system. This timeout is how long the IPC +system will wait for child processes and threads to finish before aborting. + +The default value is C<30> seconds. + +=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<Test2::Formatter::TAP>. + +You can override this default using the C<T2_FORMATTER> 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<Note:> 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</Examples/> directory included in this distribution. + +=head1 SEE ALSO + +L<Test2::API::Context> - Detailed documentation of the context object. + +L<Test2::IPC> - The IPC system used for threading/fork support. + +L<Test2::Formatter> - Formatters such as TAP live here. + +L<Test2::Event> - Events live in this namespace. + +L<Test2::Hub> - All events eventually funnel through a hub. Custom hubs are how +C<intercept()> and C<run_subtest()> 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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API/Breakage.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API/Breakage.pm new file mode 100644 index 0000000000..08aee9dcb1 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API/Breakage.pm @@ -0,0 +1,178 @@ +package Test2::API::Breakage; +use strict; +use warnings; + +our $VERSION = '1.302133'; + + +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::More::Prefix' => '0.005', + + 'Test2::Tools::EventDumper' => 0.000007, + 'Test2::Harness' => 0.000013, + + 'Test::DBIx::Class::Schema' => '1.0.9', + '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::ParallelSubtest' => '0.05', + 'Test::Pretty' => '0.32', + 'Test::Wrapper' => '0.3.0', + + '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<Test::Builder> to use L<Test2>. + +=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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API/Context.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API/Context.pm new file mode 100644 index 0000000000..6141a43ff8 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API/Context.pm @@ -0,0 +1,985 @@ +package Test2::API::Context; +use strict; +use warnings; + +our $VERSION = '1.302133'; + + +use Carp qw/confess croak/; +use Scalar::Util qw/weaken blessed/; +use Test2::Util qw/get_tid try pkg_to_file get_tid/; + +use Test2::EventFacet::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 Plan Bail Exception Waiting Skip Subtest Pass Fail V2/ +); + +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(pid => $$, 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_ev2_and_release { + my $self = shift; + my $out = $self->send_ev2(@_); + $self->release; + return $out; +} + +sub send_ev2 { + my $self = shift; + + my $e; + { + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + $e = Test2::Event::V2->new( + trace => $self->{+TRACE}->snapshot, + @_, + ); + } + + if ($self->{+_ABORTED}) { + my $f = $e->facet_data; + ${$self->{+_ABORTED}}++ if $f->{control}->{halt} || defined($f->{control}->{terminate}) || defined($e->terminate); + } + $self->{+HUB}->send($e); +} + +sub build_ev2 { + my $self = shift; + + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + Test2::Event::V2->new( + trace => $self->{+TRACE}->snapshot, + @_, + ); +} + +sub send_event_and_release { + my $self = shift; + my $out = $self->send_event(@_); + $self->release; + return $out; +} + +sub send_event { + my $self = shift; + my $event = shift; + my %args = @_; + + my $pkg = $LOADED{$event} || $self->_parse_event($event); + + my $e; + { + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + $e = $pkg->new( + trace => $self->{+TRACE}->snapshot, + %args, + ); + } + + if ($self->{+_ABORTED}) { + my $f = $e->facet_data; + ${$self->{+_ABORTED}}++ if $f->{control}->{halt} || defined($f->{control}->{terminate}) || 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); + + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + $pkg->new( + trace => $self->{+TRACE}->snapshot, + %args, + ); +} + +sub pass { + my $self = shift; + my ($name) = @_; + + my $e = bless( + { + trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), + name => $name, + }, + "Test2::Event::Pass" + ); + + $self->{+HUB}->send($e); + return $e; +} + +sub pass_and_release { + my $self = shift; + my ($name) = @_; + + my $e = bless( + { + trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), + name => $name, + }, + "Test2::Event::Pass" + ); + + $self->{+HUB}->send($e); + $self->release; + return 1; +} + +sub fail { + my $self = shift; + my ($name, @diag) = @_; + + my $e = bless( + { + trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), + name => $name, + }, + "Test2::Event::Fail" + ); + + $e->add_info({tag => 'DIAG', debug => 1, details => $_}) for @diag; + $self->{+HUB}->send($e); + return $e; +} + +sub fail_and_release { + my $self = shift; + my ($name, @diag) = @_; + + my $e = bless( + { + trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), + name => $name, + }, + "Test2::Event::Fail" + ); + + $e->add_info({tag => 'DIAG', debug => 1, details => $_}) for @diag; + $self->{+HUB}->send($e); + $self->release; + return 0; +} + +sub ok { + my $self = shift; + my ($pass, $name, $on_fail) = @_; + + my $hub = $self->{+HUB}; + + my $e = bless { + trace => bless( {%{$self->{+TRACE}}}, 'Test2::EventFacet::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) { + $self->diag($_) for @$on_fail; + } + + return $e; +} + +sub failure_diag { + my $self = shift; + my ($e) = @_; + + # 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[Failed test '$name'\n$debug.\n] + : qq[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 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<Test2>. 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<Test2::Hub> instance. + +=head1 SYNOPSIS + +In general you will not be creating contexts directly. To obtain a context you +should always use C<context()> which is exported by the L<Test2::API> 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<context()> which is exported by L<Test2::API>. + +There are a handful of cases where a tool author may want to create a new +context by hand, which is why the C<new> 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<context()> 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<Note:> If a context is acquired more than once an internal refcount is kept. +C<release()> decrements the ref count, none of the other actions of +C<release()> will occur unless the refcount hits 0. This means only the last +call to C<release()> 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<Test2::API::Stack> instance the context used to find +the current hub. + +=item $hub = $ctx->hub() + +This will return the L<Test2::Hub> instance the context recognizes as the +current one to which all events should be sent. + +=item $dbg = $ctx->trace() + +This will return the L<Test2::EventFacet::Trace> 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<DOES NOT> 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<Note:> 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 + +B<Which one do I use?> + +The C<pass*> and C<fail*> are optimal if they meet your situation, using one of +them will always be the most optimal. That said they are optimal by eliminating +many features. + +Method such as C<ok>, and C<note> are shortcuts for generating common 1-task +events based on the old API, however they are forward compatible, and easy to +use. If these meet your needs then go ahead and use them, but please check back +often for alternatives that may be added. + +If you want to generate new style events, events that do many things at once, +then you want the C<*ev2*> methods. These let you directly specify which facets +you wish to use. + +=over 4 + +=item $event = $ctx->pass() + +=item $event = $ctx->pass($name) + +This will send and return an L<Test2::Event::Pass> event. You may optionally +provide a C<$name> for the assertion. + +The L<Test2::Event::Pass> is a specially crafted and optimized event, using +this will help the performance of passing tests. + +=item $true = $ctx->pass_and_release() + +=item $true = $ctx->pass_and_release($name) + +This is a combination of C<pass()> and C<release()>. You can use this if you do +not plan to do anything with the context after sending the event. This helps +write more clear and compact code. + + sub shorthand { + my ($bool, $name) = @_; + my $ctx = context(); + return $ctx->pass_and_release($name) if $bool; + + ... Handle a failure ... + } + + sub longform { + my ($bool, $name) = @_; + my $ctx = context(); + + if ($bool) { + $ctx->pass($name); + $ctx->release; + return 1; + } + + ... Handle a failure ... + } + +=item my $event = $ctx->fail() + +=item my $event = $ctx->fail($name) + +=item my $event = $ctx->fail($name, @diagnostics) + +This lets you send an L<Test2::Event::Fail> event. You may optionally provide a +C<$name> and C<@diagnostics> messages. + +=item my $false = $ctx->fail_and_release() + +=item my $false = $ctx->fail_and_release($name) + +=item my $false = $ctx->fail_and_release($name, @diagnostics) + +This is a combination of C<fail()> and C<release()>. This can be used to write +clearer and shorter code. + + sub shorthand { + my ($bool, $name) = @_; + my $ctx = context(); + return $ctx->fail_and_release($name) unless $bool; + + ... Handle a success ... + } + + sub longform { + my ($bool, $name) = @_; + my $ctx = context(); + + unless ($bool) { + $ctx->pass($name); + $ctx->release; + return 1; + } + + ... Handle a success ... + } + + +=item $event = $ctx->ok($bool, $name) + +=item $event = $ctx->ok($bool, $name, \@on_fail) + +B<NOTE:> Use of this method is discouraged in favor of C<pass()> and C<fail()> +which produce L<Test2::Event::Pass> and L<Test2::Event::Fail> events. These +newer event types are faster and less crufty. + +This will create an L<Test2::Event::Ok> object for you. If C<$bool> is false +then an L<Test2::Event::Diag> event will be sent as well with details about the +failure. If you do not want automatic diagnostics you should use the +C<send_event()> method directly. + +The third argument C<\@on_fail>) is an optional set of diagnostics to be sent in +the event of a test failure. + +=item $event = $ctx->note($message) + +Send an L<Test2::Event::Note>. This event prints a message to STDOUT. + +=item $event = $ctx->diag($message) + +Send an L<Test2::Event::Diag>. 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<Test2::Event::Plan> 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<Test2::Event::Skip> event. + +=item $event = $ctx->bail($reason) + +This sends an L<Test2::Event::Bail> event. This event will completely +terminate all testing. + +=item $event = $ctx->send_ev2(%facets) + +This lets you build and send a V2 event directly from facets. The event is +returned after it is sent. + +This example sends a single assertion, a note (comment for stdout in +Test::Builder talk) and sets the plan to 1. + + my $event = $ctx->send_event( + plan => {count => 1}, + assert => {pass => 1, details => "A passing assert"}, + info => [{tag => 'NOTE', details => "This is a note"}], + ); + +=item $event = $ctx->build_e2(%facets) + +This is the same as C<send_ev2()>, except it builds and returns the event +without sending it. + +=item $event = $ctx->send_ev2_and_release($Type, %parameters) + +This is a combination of C<send_ev2()> and C<release()>. + + sub shorthand { + my $ctx = context(); + return $ctx->send_ev2_and_release(assert => {pass => 1, details => 'foo'}); + } + + sub longform { + my $ctx = context(); + my $event = $ctx->send_ev2(assert => {pass => 1, details => 'foo'}); + $ctx->release; + return $event; + } + +=item $event = $ctx->send_event($Type, %parameters) + +B<It is better to use send_ev2() in new code.> + +This lets you build and send an event of any type. The C<$Type> argument should +be the event package name with C<Test2::Event::> 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) + +B<It is better to use build_ev2() in new code.> + +This is the same as C<send_event()>, except it builds and returns the event +without sending it. + +=item $event = $ctx->send_event_and_release($Type, %parameters) + +B<It is better to use send_ev2_and_release() in new code.> + +This is a combination of C<send_event()> and C<release()>. + + sub shorthand { + my $ctx = context(); + return $ctx->send_event_and_release(Pass => { name => 'foo' }); + } + + sub longform { + my $ctx = context(); + my $event = $ctx->send_event(Pass => { name => 'foo' }); + $ctx->release; + return $event; + } + +=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<NOT> 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<context()> generates a new context. The callback will be ignored if +C<context()> 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<NOT> +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<ALWAYS> 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<Test2::Util::ExternalMeta> 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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Kent Fredric E<lt>kentnl@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API/Instance.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API/Instance.pm new file mode 100644 index 0000000000..0522dd77aa --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API/Instance.pm @@ -0,0 +1,916 @@ +package Test2::API::Instance; +use strict; +use warnings; + +our $VERSION = '1.302133'; + + +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 CAN_SIGSYS/; + +use Test2::EventFacet::Trace(); +use Test2::API::Stack(); + +use Test2::Util::HashBase qw{ + _pid _tid + no_wait + finalized loaded + ipc stack formatter + contexts + + add_uuid_via + + -preload + + ipc_disabled + ipc_shm_size + ipc_shm_last + ipc_shm_id + ipc_polling + ipc_drivers + ipc_timeout + formatters + + exit_callbacks + post_load_callbacks + context_acquire_callbacks + context_init_callbacks + context_release_callbacks + pre_subtest_callbacks +}; + +sub DEFAULT_IPC_TIMEOUT() { 30 } + +sub pid { $_[0]->{+_PID} } +sub tid { $_[0]->{+_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 has_ipc { !!$_[0]->{+IPC} } + +sub import { + my $class = shift; + return unless @_; + my ($ref) = @_; + $$ref = $class->new; +} + +sub init { $_[0]->reset } + +sub start_preload { + my $self = shift; + + confess "preload cannot be started, Test2::API has already been initialized" + if $self->{+FINALIZED} || $self->{+LOADED}; + + return $self->{+PRELOAD} = 1; +} + +sub stop_preload { + my $self = shift; + + return 0 unless $self->{+PRELOAD}; + $self->{+PRELOAD} = 0; + + $self->post_preload_reset(); + + return 1; +} + +sub post_preload_reset { + my $self = shift; + + delete $self->{+_PID}; + delete $self->{+_TID}; + + $self->{+ADD_UUID_VIA} = undef unless exists $self->{+ADD_UUID_VIA}; + + $self->{+CONTEXTS} = {}; + + $self->{+FORMATTERS} = []; + + $self->{+FINALIZED} = undef; + $self->{+IPC} = undef; + $self->{+IPC_DISABLED} = $ENV{T2_NO_IPC} ? 1 : 0; + + $self->{+IPC_TIMEOUT} = DEFAULT_IPC_TIMEOUT() unless defined $self->{+IPC_TIMEOUT}; + + $self->{+LOADED} = 0; + + $self->{+STACK} ||= Test2::API::Stack->new; +} + +sub reset { + my $self = shift; + + delete $self->{+_PID}; + delete $self->{+_TID}; + + $self->{+ADD_UUID_VIA} = undef; + + $self->{+CONTEXTS} = {}; + + $self->{+IPC_DRIVERS} = []; + $self->{+IPC_POLLING} = undef; + + $self->{+FORMATTERS} = []; + $self->{+FORMATTER} = undef; + + $self->{+FINALIZED} = undef; + $self->{+IPC} = undef; + $self->{+IPC_DISABLED} = $ENV{T2_NO_IPC} ? 1 : 0; + + $self->{+IPC_TIMEOUT} = DEFAULT_IPC_TIMEOUT() unless defined $self->{+IPC_TIMEOUT}; + + $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->{+PRE_SUBTEST_CALLBACKS} = []; + + $self->{+STACK} = Test2::API::Stack->new; +} + +sub _finalize { + my $self = shift; + my ($caller) = @_; + $caller ||= [caller(1)]; + + confess "Attempt to initialize Test2::API during preload" + if $self->{+PRELOAD}; + + $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 if $self->{+IPC_DISABLED}; + 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 add_pre_subtest_callback { + my $self = shift; + my ($code) = @_; + + my $rtype = reftype($code) || ""; + + confess "Pre-subtest callbacks must be coderefs" + unless $code && $rtype eq 'CODE'; + + push @{$self->{+PRE_SUBTEST_CALLBACKS}} => $code; +} + +sub load { + my $self = shift; + unless ($self->{+LOADED}) { + confess "Attempt to initialize Test2::API during preload" + if $self->{+PRELOAD}; + + $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 ipc_disable { + my $self = shift; + + confess "Attempt to disable IPC after it has been initialized" + if $self->{+IPC}; + + $self->{+IPC_DISABLED} = 1; +} + +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; + if(shmread($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE})) { + return if $val eq $self->{+IPC_SHM_LAST}; + $self->{+IPC_SHM_LAST} = $val; + } + else { + warn "SHM Read error: $!\n"; + } + + $_[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' if CAN_SIGSYS; + + 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 "Could not get shm: $!"; + + my $initial = 'a' x $shm_size; + shmwrite($shm_id, $initial, 0, $shm_size) or die "Could not write to shm: $!"; + my $val; + shmread($shm_id, $val, 0, $shm_size) or die "Could not read from shm: $!"; + die "Read SHM value does not match the initial value ('$val' vs '$initial')" + unless $val eq $initial; + + $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 ($timeout) = @_; + my $fail = 0; + + $timeout = DEFAULT_IPC_TIMEOUT() unless defined $timeout; + + my $ok = eval { + if (CAN_FORK) { + local $SIG{ALRM} = sub { die "Timeout waiting on child processes" }; + alarm $timeout; + + while (1) { + my $pid = CORE::wait(); + my $err = $?; + last if $pid == -1; + next unless $err; + $fail++; + + my $sig = $err & 127; + my $exit = $err >> 8; + warn "Process $pid did not exit cleanly (wstat: $err, exit: $exit, sig: $sig)\n"; + } + + alarm 0; + } + + if (USE_THREADS) { + my $start = time; + + while (1) { + last unless threads->list(); + die "Timeout waiting on child thread" if time - $start >= $timeout; + sleep 1; + for my $t (threads->list) { + # threads older than 1.34 do not have this :-( + next if $t->can('is_joinable') && !$t->is_joinable; + $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"; + } + } + } + + 1; + }; + my $error = $@; + + return 0 if $ok && !$fail; + warn $error unless $ok; + return 255; +} + +sub DESTROY { + my $self = shift; + + return if $self->{+PRELOAD}; + + 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; + + return if $self->{+PRELOAD}; + + 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($self->{+IPC_TIMEOUT}); + $new_exit ||= $ipc_exit; + } + + # None of this is necessary if we never got a root hub + if(my $root = shift @hubs) { + my $trace = Test2::EventFacet::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<Test2>. A single global instance of this package is stored (and +obscured) by the L<Test2::API> 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<load()> has already been called then the callback will +be immediately executed. If C<load()> has not been called then the callback will be +stored and executed later when C<load()> 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 $arrayref = $obj->pre_subtest_callbacks + +Get all pre-subtest 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->add_pre_subtest_callback(sub { ... }) + +Add a pre-subtest callback. Subs are called every time a subtest is +going to be run. Subs get the subtest name, coderef, and any +arguments. + +=item $obj->set_exit() + +This is intended to be called in an C<END { ... }> 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<Note:> This will also make the current process see a pending event. It does +not set C<ipc_shm_last()>, 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 $timeout = $obj->ipc_timeout; + +=item $obj->set_ipc_timeout($timeout); + +How long to wait for child processes and threads before aborting. + +=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<set_exit()>. + +=item $bool = $obj->finalized + +Check if the object is finalized. Finalization happens when either C<ipc()>, +C<stack()>, or C<format()> are called on the object. Once finalization happens +these fields are considered unchangeable (not enforced here, enforced by +L<Test2>). + +=item $ipc = $obj->ipc + +Get the one true IPC instance. + +=item $obj->ipc_disable + +Turn IPC off + +=item $bool = $obj->ipc_disabled + +Check if IPC is disabled + +=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<write()> 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" + +=item $obj->set_add_uuid_via(sub { ... }) + +=item $sub = $obj->add_uuid_via() + +This allows you to provide a UUID generator. If provided UUIDs will be attached +to all events, hubs, and contexts. This is useful for storing, tracking, and +linking these objects. + +The sub you provide should always return a unique identifier. Most things will +expect a proper UUID string, however nothing in Test2::API enforces this. + +The sub will receive exactly 1 argument, the type of thing being tagged +'context', 'hub', or 'event'. In the future additional things may be tagged, in +which case new strings will be passed in. These are purely informative, you can +(and usually should) ignore them. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API/Stack.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API/Stack.pm new file mode 100644 index 0000000000..8007e1a654 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API/Stack.pm @@ -0,0 +1,220 @@ +package Test2::API::Stack; +use strict; +use warnings; + +our $VERSION = '1.302133'; + + +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_root) + 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<Test2::Hub> +instances. + +=head1 ***INTERNALS NOTE*** + +B<The internals of this package are subject to change at any time!> The public +methods provided will not change in backwards incompatible ways, but the +underlying implementation details might. B<Do not break encapsulation here!> + +=head1 DESCRIPTION + +This module is used to represent and manage a stack of L<Test2::Hub> +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<Test2::Hub> 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<undef> 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<Test2::API> 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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event.pm new file mode 100644 index 0000000000..307d49b75e --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event.pm @@ -0,0 +1,774 @@ +package Test2::Event; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +use Scalar::Util qw/blessed reftype/; +use Carp qw/croak/; + +use Test2::Util::HashBase qw/trace -amnesty uuid -hubs/; +use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; +use Test2::Util qw(pkg_to_file); + +use Test2::EventFacet::About(); +use Test2::EventFacet::Amnesty(); +use Test2::EventFacet::Assert(); +use Test2::EventFacet::Control(); +use Test2::EventFacet::Error(); +use Test2::EventFacet::Info(); +use Test2::EventFacet::Meta(); +use Test2::EventFacet::Parent(); +use Test2::EventFacet::Plan(); +use Test2::EventFacet::Trace(); +use Test2::EventFacet::Hub(); + +# Legacy tools will expect this to be loaded now +require Test2::Util::Trace; + +my %LOADED_FACETS = ( + 'about' => 'Test2::EventFacet::About', + 'amnesty' => 'Test2::EventFacet::Amnesty', + 'assert' => 'Test2::EventFacet::Assert', + 'control' => 'Test2::EventFacet::Control', + 'errors' => 'Test2::EventFacet::Error', + 'info' => 'Test2::EventFacet::Info', + 'meta' => 'Test2::EventFacet::Meta', + 'parent' => 'Test2::EventFacet::Parent', + 'plan' => 'Test2::EventFacet::Plan', + 'trace' => 'Test2::EventFacet::Trace', + 'hubs' => 'Test2::EventFacet::Hub', +); + +sub FACET_TYPES { sort values %LOADED_FACETS } + +sub load_facet { + my $class = shift; + my ($facet) = @_; + + return $LOADED_FACETS{$facet} if exists $LOADED_FACETS{$facet}; + + my @check = ($facet); + if ('s' eq substr($facet, -1, 1)) { + push @check => substr($facet, 0, -1); + } + else { + push @check => $facet . 's'; + } + + my $found; + for my $check (@check) { + my $mod = "Test2::EventFacet::" . ucfirst($facet); + my $file = pkg_to_file($mod); + next unless eval { require $file; 1 }; + $found = $mod; + last; + } + + return undef unless $found; + $LOADED_FACETS{$facet} = $found; +} + +sub causes_fail { 0 } +sub increments_count { 0 } +sub diagnostics { 0 } +sub no_display { 0 } +sub subtest_id { undef } + +sub callback { } + +sub terminate { () } +sub global { () } +sub sets_plan { () } + +sub summary { ref($_[0]) } + +sub related { + my $self = shift; + my ($event) = @_; + + my $tracea = $self->trace or return undef; + my $traceb = $event->trace or return undef; + + my $uuida = $tracea->uuid; + my $uuidb = $traceb->uuid; + if ($uuida && $uuidb) { + return 1 if $uuida eq $uuidb; + return 0; + } + + my $siga = $tracea->signature or return undef; + my $sigb = $traceb->signature or return undef; + + return 1 if $siga eq $sigb; + return 0; +} + +sub add_hub { + my $self = shift; + unshift @{$self->{+HUBS}} => @_; +} + +sub add_amnesty { + my $self = shift; + + for my $am (@_) { + $am = {%$am} if ref($am) ne 'ARRAY'; + $am = Test2::EventFacet::Amnesty->new($am); + + push @{$self->{+AMNESTY}} => $am; + } +} + +sub common_facet_data { + my $self = shift; + + my %out; + + $out{about} = {package => ref($self) || undef}; + if (my $uuid = $self->uuid) { + $out{about}->{uuid} = $uuid; + } + + if (my $trace = $self->trace) { + $out{trace} = { %$trace }; + } + + if (my $hubs = $self->hubs) { + $out{hubs} = $hubs; + } + + $out{amnesty} = [map {{ %{$_} }} @{$self->{+AMNESTY}}] + if $self->{+AMNESTY}; + + if (my $meta = $self->meta_facet_data) { + $out{meta} = $meta; + } + + return \%out; +} + +sub meta_facet_data { + my $self = shift; + + my $key = Test2::Util::ExternalMeta::META_KEY(); + + my $hash = $self->{$key} or return undef; + return {%$hash}; +} + +sub facet_data { + my $self = shift; + + my $out = $self->common_facet_data; + + $out->{about}->{details} = $self->summary || undef; + $out->{about}->{no_display} = $self->no_display || undef; + + # Might be undef, we want to preserve that + my $terminate = $self->terminate; + $out->{control} = { + global => $self->global || 0, + terminate => $terminate, + has_callback => $self->can('callback') == \&callback ? 0 : 1, + }; + + $out->{assert} = { + no_debug => 1, # Legacy behavior + pass => $self->causes_fail ? 0 : 1, + details => $self->summary, + } if $self->increments_count; + + $out->{parent} = {hid => $self->subtest_id} if $self->subtest_id; + + if (my @plan = $self->sets_plan) { + $out->{plan} = {}; + + $out->{plan}->{count} = $plan[0] if defined $plan[0]; + $out->{plan}->{details} = $plan[2] if defined $plan[2]; + + if ($plan[1]) { + $out->{plan}->{skip} = 1 if $plan[1] eq 'SKIP'; + $out->{plan}->{none} = 1 if $plan[1] eq 'NO PLAN'; + } + + $out->{control}->{terminate} ||= 0 if $out->{plan}->{skip}; + } + + if ($self->causes_fail && !$out->{assert}) { + $out->{errors} = [ + { + tag => 'FAIL', + fail => 1, + details => $self->summary, + } + ]; + } + + my %IGNORE = (trace => 1, about => 1, control => 1); + my $do_info = !grep { !$IGNORE{$_} } keys %$out; + + if ($do_info && !$self->no_display && $self->diagnostics) { + $out->{info} = [ + { + tag => 'DIAG', + debug => 1, + details => $self->summary, + } + ]; + } + + return $out; +} + +sub facets { + my $self = shift; + my %out; + + my $data = $self->facet_data; + my @errors = $self->validate_facet_data($data); + die join "\n" => @errors if @errors; + + for my $facet (keys %$data) { + my $class = $self->load_facet($facet); + my $val = $data->{$facet}; + + unless($class) { + $out{$facet} = $val; + next; + } + + my $is_list = reftype($val) eq 'ARRAY' ? 1 : 0; + if ($is_list) { + $out{$facet} = [map { $class->new($_) } @$val]; + } + else { + $out{$facet} = $class->new($val); + } + } + + return \%out; +} + +sub validate_facet_data { + my $class_or_self = shift; + my ($f, %params); + + $f = shift if @_ && (reftype($_[0]) || '') eq 'HASH'; + %params = @_; + + $f ||= $class_or_self->facet_data if blessed($class_or_self); + croak "No facet data" unless $f; + + my @errors; + + for my $k (sort keys %$f) { + my $fclass = $class_or_self->load_facet($k); + + push @errors => "Could not find a facet class for facet '$k'" + if $params{require_facet_class} && !$fclass; + + next unless $fclass; + + my $v = $f->{$k}; + next unless defined($v); # undef is always fine + + my $is_list = $fclass->is_list(); + my $got_list = reftype($v) eq 'ARRAY' ? 1 : 0; + + push @errors => "Facet '$k' should be a list, but got a single item ($v)" + if $is_list && !$got_list; + + push @errors => "Facet '$k' should not be a list, but got a a list ($v)" + if $got_list && !$is_list; + } + + return @errors; +} + +sub nested { + my $self = shift; + + Carp::cluck("Use of Test2::Event->nested() is deprecated, use Test2::Event->trace->nested instead") + if $ENV{AUTHOR_TESTING}; + + if (my $hubs = $self->{+HUBS}) { + return $hubs->[0]->{nested} if @$hubs; + } + + my $trace = $self->{+TRACE} or return undef; + return $trace->{nested}; +} + +sub in_subtest { + my $self = shift; + + Carp::cluck("Use of Test2::Event->in_subtest() is deprecated, use Test2::Event->trace->hid instead") + if $ENV{AUTHOR_TESTING}; + + my $hubs = $self->{+HUBS}; + if ($hubs && @$hubs) { + return undef unless $hubs->[0]->{nested}; + return $hubs->[0]->{hid} + } + + my $trace = $self->{+TRACE} or return undef; + return undef unless $trace->{nested}; + return $trace->{hid}; +} + +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<Test2>. + +=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/; + + # Use this if you want the legacy API to be written for you, for this to + # work you will need to implement a facet_data() method. + use Test2::Util::Facets2Legacy; + + # Chance to initialize some defaults + sub init { + my $self = shift; + # no other args in @_ + + $self->set_foo('xxx') unless defined $self->foo; + + ... + } + + # This is the new way for events to convey data to the Test2 system + sub facet_data { + my $self = shift; + + # Get common facets such as 'about', 'trace' 'amnesty', and 'meta' + my $facet_data = $self->common_facet_data(); + + # Are you making an assertion? + $facet_data->{assert} = {pass => 1, details => 'my assertion'}; + ... + + return $facet_data; + } + + 1; + +=head1 METHODS + +=head2 GENERAL + +=over 4 + +=item $trace = $e->trace + +Get a snapshot of the L<Test2::EventFacet::Trace> as it was when this event was +generated + +=item $bool_or_undef = $e->related($e2) + +Check if 2 events are related. In this case related means their traces share a +signature meaning they were created with the same context (or at the very least +by contexts which share an id, which is the same thing unless someone is doing +something very bad). + +This can be used to reliably link multiple events created by the same tool. For +instance a failing test like C<ok(0, "fail"> will generate 2 events, one being +a L<Test2::Event::Ok>, the other being a L<Test2::Event::Diag>, both of these +events are related having been created under the same context and by the same +initial tool (though multiple tools may have been nested under the initial +one). + +This will return C<undef> if the relationship cannot be checked, which happens +if either event has an incomplete or missing trace. This will return C<0> if +the traces are complete, but do not match. C<1> will be returned if there is a +match. + +=item $e->add_amnesty({tag => $TAG, details => $DETAILS}); + +This can be used to add amnesty to this event. Amnesty only effects failing +assertions in most cases, but some formatters may display them for passing +assertions, or even non-assertions as well. + +Amnesty will prevent a failed assertion from causing the overall test to fail. +In other words it marks a failure as expected and allowed. + +B<Note:> This is how 'TODO' is implemented under the hood. TODO is essentially +amnesty with the 'TODO' tag. The details are the reason for the TODO. + +=item $uuid = $e->uuid + +If UUID tagging is enabled (See L<Test::API>) then any event that has made its +way through a hub will be tagged with a UUID. A newly created event will not +yet be tagged in most cases. + +=item $class = $e->load_facet($name) + +This method is used to load a facet by name (or key). It will attempt to load +the facet class, if it succeeds it will return the class it loaded. If it fails +it will return C<undef>. This caches the result at the class level so that +future calls will be faster. + +The C<$name> variable should be the key used to access the facet in a facets +hashref. For instance the assertion facet has the key 'assert', the information +facet has the 'info' key, and the error facet has the key 'errors'. You may +include or omit the 's' at the end of the name, the method is smart enough to +try both the 's' and no-'s' forms, it will check what you provided first, and +if that is not found it will add or strip the 's and try again. + +=item @classes = $e->FACET_TYPES() + +=item @classes = Test2::Event->FACET_TYPES() + +This returns a list of all facets that have been loaded using the +C<load_facet()> method. This will not return any classes that have not been +loaded, or have been loaded directly without a call to C<load_facet()>. + +B<Note:> The core facet types are automatically loaded and populated in this +list. + +=back + +=head2 NEW API + +=over 4 + +=item $hashref = $e->common_facet_data(); + +This can be used by subclasses to generate a starting facet data hashref. This +will populate the hashref with the trace, meta, amnesty, and about facets. +These facets are nearly always produced the same way for all events. + +=item $hashref = $e->facet_data() + +If you do not override this then the default implementation will attempt to +generate facets from the legacy API. This generation is limited only to what +the legacy API can provide. It is recommended that you override this method and +write out explicit facet data. + +=item $hashref = $e->facets() + +This takes the hashref from C<facet_data()> and blesses each facet into the +proper C<Test2::EventFacet::*> subclass. If no class can be found for any given +facet it will be passed along unchanged. + +=item @errors = $e->validate_facet_data(); + +=item @errors = $e->validate_facet_data(%params); + +=item @errors = $e->validate_facet_data(\%facets, %params); + +=item @errors = Test2::Event->validate_facet_data(%params); + +=item @errors = Test2::Event->validate_facet_data(\%facets, %params); + +This method will validate facet data and return a list of errors. If no errors +are found this will return an empty list. + +This can be called as an object method with no arguments, in which case the +C<facet_data()> method will be called to get the facet data to be validated. + +When used as an object method the C<\%facet_data> argument may be omitted. + +When used as a class method the C<\%facet_data> argument is required. + +Remaining arguments will be slurped into a C<%params> hash. + +Currently only 1 parameter is defined: + +=over 4 + +=item require_facet_class => $BOOL + +When set to true (default is false) this will reject any facets where a facet +class cannot be found. Normally facets without classes are assumed to be custom +and are ignored. + +=back + +=back + +=head3 WHAT ARE FACETS? + +Facets are how events convey their purpose to the Test2 internals and +formatters. An event without facets will have no intentional effect on the +overall test state, and will not be displayed at all by most formatters, except +perhaps to say that an event of an unknown type was seen. + +Facets are produced by the C<facet_data()> subroutine, which you should +nearly-always override. C<facet_data()> is expected to return a hashref where +each key is the facet type, and the value is either a hashref with the data for +that facet, or an array of hashref's. Some facets must be defined as single +hashrefs, some must be defined as an array of hashrefs, No facets allow both. + +C<facet_data()> B<MUST NOT> bless the data it returns, the main hashref, and +nested facet hashref's B<MUST> be bare, though items contained within each +facet may be blessed. The data returned by this method B<should> also be copies +of the internal data in order to prevent accidental state modification. + +C<facets()> takes the data from C<facet_data()> and blesses it into the +C<Test2::EventFacet::*> packages. This is rarely used however, the EventFacet +packages are primarily for convenience and documentation. The EventFacet +classes are not used at all internally, instead the raw data is used. + +Here is a list of facet types by package. The packages are not used internally, +but are where the documentation for each type is kept. + +B<Note:> Every single facet type has the C<'details'> field. This field is +always intended for human consumption, and when provided, should explain the +'why' for the facet. All other fields are facet specific. + +=over 4 + +=item about => {...} + +L<Test2::EventFacet::About> + +This contains information about the event itself such as the event package +name. The C<details> field for this facet is an overall summary of the event. + +=item assert => {...} + +L<Test2::EventFacet::Assert> + +This facet is used if an assertion was made. The C<details> field of this facet +is the description of the assertion. + +=item control => {...} + +L<Test2::EventFacet::Control> + +This facet is used to tell the L<Test2::Event::Hub> about special actions the +event causes. Things like halting all testing, terminating the current test, +etc. In this facet the C<details> field explains why any special action was +taken. + +B<Note:> This is how bail-out is implemented. + +=item meta => {...} + +L<Test2::EventFacet::Meta> + +The meta facet contains all the meta-data attached to the event. In this case +the C<details> field has no special meaning, but may be present if something +sets the 'details' meta-key on the event. + +=item parent => {...} + +L<Test2::EventFacet::Parent> + +This facet contains nested events and similar details for subtests. In this +facet the C<details> field will typically be the name of the subtest. + +=item plan => {...} + +L<Test2::EventFacet::Plan> + +This facet tells the system that a plan has been set. The C<details> field of +this is usually left empty, but when present explains why the plan is what it +is, this is most useful if the plan is to skip-all. + +=item trace => {...} + +L<Test2::EventFacet::Trace> + +This facet contains information related to when and where the event was +generated. This is how the test file and line number of a failure is known. +This facet can also help you to tell if tests are related. + +In this facet the C<details> field overrides the "failed at test_file.t line +42." message provided on assertion failure. + +=item amnesty => [{...}, ...] + +L<Test2::EventFacet::Amnesty> + +The amnesty facet is a list instead of a single item, this is important as +amnesty can come from multiple places at once. + +For each instance of amnesty the C<details> field explains why amnesty was +granted. + +B<Note:> Outside of formatters amnesty only acts to forgive a failing +assertion. + +=item errors => [{...}, ...] + +L<Test2::EventFacet::Error> + +The errors facet is a list instead of a single item, any number of errors can +be listed. In this facet C<details> describes the error, or may contain the raw +error message itself (such as an exception). In perl exception may be blessed +objects, as such the raw data for this facet may contain nested items which are +blessed. + +Not all errors are considered fatal, there is a C<fail> field that must be set +for an error to cause the test to fail. + +B<Note:> This facet is unique in that the field name is 'errors' while the +package is 'Error'. This is because this is the only facet type that is both a +list, and has a name where the plural is not the same as the singular. This may +cause some confusion, but I feel it will be less confusing than the +alternative. + +=item info => [{...}, ...] + +L<Test2::EventFacet::Info> + +The 'info' facet is a list instead of a single item, any quantity of extra +information can be attached to an event. Some information may be critical +diagnostics, others may be simply commentary in nature, this is determined by +the C<debug> flag. + +For this facet the C<details> flag is the info itself. This info may be a +string, or it may be a data structure to display. This is one of the few facet +types that may contain blessed items. + +=back + +=head2 LEGACY API + +=over 4 + +=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<Test2::Hub> you can override +this method. + +This is called B<BEFORE> your event is passed to the formatter. + +=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<AFTER> 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<Test2::Event::Plan> to exit 0 when the plan is +'skip_all'. This is also used by L<Test2::Event:Bail> 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 $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. + +=back + +=head1 THIRD PARTY META-DATA + +This object consumes L<Test2::Util::ExternalMeta> 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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Bail.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Bail.pm new file mode 100644 index 0000000000..bfd99ee3aa --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Bail.pm @@ -0,0 +1,109 @@ +package Test2::Event::Bail; +use strict; +use warnings; + +our $VERSION = '1.302133'; + + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw{reason buffered}; + +# 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 } + +sub facet_data { + my $self = shift; + my $out = $self->common_facet_data; + + $out->{control} = { + global => 1, + halt => 1, + details => $self->{+REASON}, + terminate => 255, + }; + + return $out; +} + +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<Test2::Event>. 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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Diag.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Diag.pm new file mode 100644 index 0000000000..f5d3a6a49e --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Diag.pm @@ -0,0 +1,99 @@ +package Test2::Event::Diag; +use strict; +use warnings; + +our $VERSION = '1.302133'; + + +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 } + +sub facet_data { + my $self = shift; + + my $out = $self->common_facet_data; + + $out->{info} = [ + { + tag => 'DIAG', + debug => 1, + details => $self->{+MESSAGE}, + } + ]; + + return $out; +} + +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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Encoding.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Encoding.pm new file mode 100644 index 0000000000..cd4b28dcbe --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Encoding.pm @@ -0,0 +1,97 @@ +package Test2::Event::Encoding; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +use Carp qw/croak/; + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw/encoding/; + +sub init { + my $self = shift; + defined $self->{+ENCODING} or croak "'encoding' is a required attribute"; +} + +sub summary { 'Encoding set to ' . $_[0]->{+ENCODING} } + +sub facet_data { + my $self = shift; + my $out = $self->common_facet_data; + $out->{control}->{encoding} = $self->{+ENCODING}; + $out->{about}->{details} = $self->summary; + return $out; +} + + +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<Test2::Event>. 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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Exception.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Exception.pm new file mode 100644 index 0000000000..4ec36c57fa --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Exception.pm @@ -0,0 +1,113 @@ +package Test2::Event::Exception; +use strict; +use warnings; + +our $VERSION = '1.302133'; + + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw{error}; + +sub init { + my $self = shift; + $self->{+ERROR} = "$self->{+ERROR}"; +} + +sub causes_fail { 1 } + +sub summary { + my $self = shift; + chomp(my $msg = "Exception: " . $self->{+ERROR}); + return $msg; +} + +sub diagnostics { 1 } + +sub facet_data { + my $self = shift; + my $out = $self->common_facet_data; + + $out->{errors} = [ + { + tag => 'ERROR', + fail => 1, + details => $self->{+ERROR}, + } + ]; + + return $out; +} + + +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<Test2::Event>. Also defines: + +=over 4 + +=item $reason = $e->error + +The reason for the exception. + +=back + +=head1 CAVEATS + +Be aware that all exceptions are stringified during construction. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Fail.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Fail.pm new file mode 100644 index 0000000000..f243918627 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Fail.pm @@ -0,0 +1,118 @@ +package Test2::Event::Fail; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +use Test2::EventFacet::Info; + +BEGIN { + require Test2::Event; + our @ISA = qw(Test2::Event); + *META_KEY = \&Test2::Util::ExternalMeta::META_KEY; +} + +use Test2::Util::HashBase qw{ -name -info }; + +############# +# Old API +sub summary { "fail" } +sub increments_count { 1 } +sub diagnostics { 0 } +sub no_display { 0 } +sub subtest_id { undef } +sub terminate { () } +sub global { () } +sub sets_plan { () } + +sub causes_fail { + my $self = shift; + return 0 if $self->{+AMNESTY} && @{$self->{+AMNESTY}}; + return 1; +} + +############# +# New API + +sub add_info { + my $self = shift; + + for my $in (@_) { + $in = {%$in} if ref($in) ne 'ARRAY'; + $in = Test2::EventFacet::Info->new($in); + + push @{$self->{+INFO}} => $in; + } +} + +sub facet_data { + my $self = shift; + my $out = $self->common_facet_data; + + $out->{about}->{details} = 'fail'; + + $out->{assert} = {pass => 0, details => $self->{+NAME}}; + + $out->{info} = [map {{ %{$_} }} @{$self->{+INFO}}] if $self->{+INFO}; + + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Fail - Event for a simple failed assertion + +=head1 DESCRIPTION + +This is an optimal representation of a failed assertion. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + + sub fail { + my ($name) = @_; + my $ctx = context(); + $ctx->fail($name); + $ctx->release; + } + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Generic.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Generic.pm new file mode 100644 index 0000000000..b5bf934135 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Generic.pm @@ -0,0 +1,280 @@ +package Test2::Event::Generic; +use strict; +use warnings; + +use Carp qw/croak/; +use Scalar::Util qw/reftype/; + +our $VERSION = '1.302133'; + +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 facet_data +}; +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'; + + *$field = sub { exists $_[0]->{$field} ? $_[0]->{$field} : () } + unless exists &{$field}; + + *{"set_$field"} = sub { $_[0]->{$field} = $_[1] } + unless exists &{"set_$field"}; +} + +sub can { + my $self = shift; + my ($name) = @_; + return $self->SUPER::can($name) unless $name eq 'callback'; + return $self->{callback} || \&Test2::Event::callback; +} + +sub facet_data { + my $self = shift; + return $self->{facet_data} || $self->SUPER::facet_data(); +} + +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->facet_data($data) + +=item $data = $e->facet_data + +Get or set the facet data (see L<Test2::Event>). If no facet_data is set then +C<< Test2::Event->facet_data >> will be called to produce facets from the other +data. + +=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<Test2::Event::Hub> that is using the callback. + +=item $bool = $e->causes_fail + +=item $e->set_causes_fail($bool) + +Get/Set the C<causes_fail> attribute. This defaults to C<0>. + +=item $bool = $e->diagnostics + +=item $e->set_diagnostics($bool) + +Get/Set the C<diagnostics> 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<diagnostics> 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<increments_count> attribute. This defaults to C<0>. + +=item $bool = $e->no_display + +=item $e->set_no_display($bool) + +Get/Set the C<no_display> 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<undef> 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<terminate> 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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Note.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Note.pm new file mode 100644 index 0000000000..2fb1d0d6b9 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Note.pm @@ -0,0 +1,97 @@ +package Test2::Event::Note; +use strict; +use warnings; + +our $VERSION = '1.302133'; + + +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 facet_data { + my $self = shift; + + my $out = $self->common_facet_data; + + $out->{info} = [ + { + tag => 'NOTE', + debug => 0, + details => $self->{+MESSAGE}, + } + ]; + + return $out; +} + +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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Ok.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Ok.pm new file mode 100644 index 0000000000..fb9a8db529 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Ok.pm @@ -0,0 +1,162 @@ +package Test2::Event::Ok; +use strict; +use warnings; + +our $VERSION = '1.302133'; + + +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; +} + +sub extra_amnesty { + my $self = shift; + return unless defined($self->{+TODO}) || ($self->{+EFFECTIVE_PASS} && !$self->{+PASS}); + return { + tag => 'TODO', + details => $self->{+TODO}, + }; +} + +sub facet_data { + my $self = shift; + + my $out = $self->common_facet_data; + + $out->{assert} = { + no_debug => 1, # Legacy behavior + pass => $self->{+PASS}, + details => $self->{+NAME}, + }; + + if (my @exra_amnesty = $self->extra_amnesty) { + unshift @{$out->{amnesty}} => @exra_amnesty; + } + + return $out; +} + +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<ok()>, and C<is()>. + +=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. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Pass.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Pass.pm new file mode 100644 index 0000000000..78fe1b2f3f --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Pass.pm @@ -0,0 +1,114 @@ +package Test2::Event::Pass; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +use Test2::EventFacet::Info; + +BEGIN { + require Test2::Event; + our @ISA = qw(Test2::Event); + *META_KEY = \&Test2::Util::ExternalMeta::META_KEY; +} + +use Test2::Util::HashBase qw{ -name -info }; + +############## +# Old API +sub summary { "pass" } +sub increments_count { 1 } +sub causes_fail { 0 } +sub diagnostics { 0 } +sub no_display { 0 } +sub subtest_id { undef } +sub terminate { () } +sub global { () } +sub sets_plan { () } + +############## +# New API + +sub add_info { + my $self = shift; + + for my $in (@_) { + $in = {%$in} if ref($in) ne 'ARRAY'; + $in = Test2::EventFacet::Info->new($in); + + push @{$self->{+INFO}} => $in; + } +} + +sub facet_data { + my $self = shift; + + my $out = $self->common_facet_data; + + $out->{about}->{details} = 'pass'; + + $out->{assert} = {pass => 1, details => $self->{+NAME}}; + + $out->{info} = [map {{ %{$_} }} @{$self->{+INFO}}] if $self->{+INFO}; + + return $out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::Pass - Event for a simple passing assertion + +=head1 DESCRIPTION + +This is an optimal representation of a passing assertion. + +=head1 SYNOPSIS + + use Test2::API qw/context/; + + sub pass { + my ($name) = @_; + my $ctx = context(); + $ctx->pass($name); + $ctx->release; + } + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Plan.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Plan.pm new file mode 100644 index 0000000000..a75e14d687 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Plan.pm @@ -0,0 +1,169 @@ +package Test2::Event::Plan; +use strict; +use warnings; + +our $VERSION = '1.302133'; + + +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 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'"; +} + +sub facet_data { + my $self = shift; + + my $out = $self->common_facet_data; + + $out->{control}->{terminate} = $self->{+DIRECTIVE} eq 'SKIP' ? 0 : undef + unless defined $out->{control}->{terminate}; + + $out->{plan} = {count => $self->{+MAX}}; + $out->{plan}->{details} = $self->{+REASON} if defined $self->{+REASON}; + + if (my $dir = $self->{+DIRECTIVE}) { + $out->{plan}->{skip} = 1 if $dir eq 'SKIP'; + $out->{plan}->{none} = 1 if $dir eq 'NO PLAN'; + } + + return $out; +} + + +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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Skip.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Skip.pm new file mode 100644 index 0000000000..7a2e660f51 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Skip.pm @@ -0,0 +1,127 @@ +package Test2::Event::Skip; +use strict; +use warnings; + +our $VERSION = '1.302133'; + + +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; +} + +sub extra_amnesty { + my $self = shift; + + my @out; + + push @out => { + tag => 'TODO', + details => $self->{+TODO}, + } if defined $self->{+TODO}; + + push @out => { + tag => 'skip', + details => $self->{+REASON}, + inherited => 0, + }; + + 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<Test2::Event::Ok> 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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Subtest.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Subtest.pm new file mode 100644 index 0000000000..3feb0f10ca --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Subtest.pm @@ -0,0 +1,160 @@ +package Test2::Event::Subtest; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) } +use Test2::Util::HashBase qw{subevents buffered subtest_id subtest_uuid}; + +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; +} + +sub facet_data { + my $self = shift; + + my $out = $self->SUPER::facet_data(); + + $out->{parent} = { + hid => $self->subtest_id, + children => [map {$_->facet_data} @{$self->{+SUBEVENTS}}], + buffered => $self->{+BUFFERED}, + }; + + return $out; +} + +sub add_amnesty { + my $self = shift; + + for my $am (@_) { + $am = {%$am} if ref($am) ne 'ARRAY'; + $am = Test2::EventFacet::Amnesty->new($am); + + push @{$self->{+AMNESTY}} => $am; + + for my $e (@{$self->{+SUBEVENTS}}) { + $e->add_amnesty($am->clone(inherited => 1)); + } + } +} + + +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<Test2::Event::Ok>. + +=head1 ACCESSORS + +This class inherits from L<Test2::Event::Ok>. + +=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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/TAP/Version.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/TAP/Version.pm new file mode 100644 index 0000000000..03f2621c0e --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/TAP/Version.pm @@ -0,0 +1,101 @@ +package Test2::Event::TAP::Version; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +use Carp qw/croak/; + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase qw/version/; + +sub init { + my $self = shift; + defined $self->{+VERSION} or croak "'version' is a required attribute"; +} + +sub summary { 'TAP version ' . $_[0]->{+VERSION} } + +sub facet_data { + my $self = shift; + + my $out = $self->common_facet_data; + + $out->{about}->{details} = $self->summary; + + push @{$out->{info}} => { + tag => 'INFO', + debug => 0, + details => $self->summary, + }; + + return $out; +} + +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<Test2::Event>. 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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/V2.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/V2.pm new file mode 100644 index 0000000000..86a44d4c28 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/V2.pm @@ -0,0 +1,238 @@ +package Test2::Event::V2; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +use Scalar::Util qw/reftype/; +use Carp qw/croak/; + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } + +use Test2::Util::Facets2Legacy qw{ + causes_fail diagnostics global increments_count no_display sets_plan + subtest_id summary terminate +}; + +use Test2::Util::HashBase qw/-about/; + +sub non_facet_keys { + return ( + +UUID, + Test2::Util::ExternalMeta::META_KEY(), + ); +} + +sub init { + my $self = shift; + + my $uuid; + if ($uuid = $self->{+UUID}) { + croak "uuid '$uuid' passed to constructor, but uuid '$self->{+ABOUT}->{uuid}' is already set in the 'about' facet" + if $self->{+ABOUT}->{uuid} && $self->{+ABOUT}->{uuid} ne $uuid; + + $self->{+ABOUT}->{uuid} = $uuid; + } + elsif ($uuid = $self->{+ABOUT}->{uuid}) { + $self->SUPER::set_uuid($uuid); + } + + # Clone the trace, make sure it is blessed + if (my $trace = $self->{+TRACE}) { + $self->{+TRACE} = Test2::EventFacet::Trace->new(%$trace); + } +} + +sub set_uuid { + my $self = shift; + my ($uuid) = @_; + $self->{+ABOUT}->{uuid} = $uuid; + $self->SUPER::set_uuid($uuid); +} + +sub facet_data { + my $self = shift; + my $f = { %{$self} }; + + delete $f->{$_} for $self->non_facet_keys; + + my %out; + for my $k (keys %$f) { + next if substr($k, 0, 1) eq '_'; + + my $data = $f->{$k}; + my $is_list = reftype($data) eq 'ARRAY'; + $out{$k} = $is_list ? [ map { {%{$_}} } @$data ] : {%$data}; + } + + if (my $meta = $self->meta_facet_data) { + $out{meta} = {%$meta, %{$out{meta} || {}}}; + } + + return \%out; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Event::V2 - Second generation event. + +=head1 DESCRIPTION + +This is the event type that should be used instead of L<Test2::Event> or its +legacy subclasses. + +=head1 SYNOPSIS + +=head2 USING A CONTEXT + + use Test2::API qw/context/; + + sub my_tool { + my $ctx = context(); + + my $event = $ctx->send_ev2(info => [{tag => 'NOTE', details => "This is a note"}]); + + $ctx->release; + + return $event; + } + +=head2 USING THE CONSTRUCTOR + + use Test2::Event::V2; + + my $e = Test2::Event::V2->new( + trace => {frame => [$PKG, $FILE, $LINE, $SUBNAME]}, + info => [{tag => 'NOTE', details => "This is a note"}], + ); + +=head1 METHODS + +This class inherits from L<Test2::Event>. + +=over 4 + +=item $fd = $e->facet_data() + +This will return a hashref of facet data. Each facet hash will be a shallow +copy of the original. + +=item $about = $e->about() + +This will return the 'about' facet hashref. + +B<NOTE:> This will return the internal hashref, not a copy. + +=item $trace = $e->trace() + +This will return the 'trace' facet, normally blessed (but this is not enforced +when the trace is set using C<set_trace()>. + +B<NOTE:> This will return the internal trace, not a copy. + +=back + +=head2 MUTATION + +=over 4 + +=item $e->add_amnesty({...}) + +Inherited from L<Test2::Event>. This can be used to add 'amnesty' facets to an +existing event. Each new item is added to the B<END> of the list. + +B<NOTE:> Items B<ARE> blessed when added. + +=item $e->add_hub({...}) + +Inherited from L<Test2::Event>. This is used by hubs to stamp events as they +pass through. New items are added to the B<START> of the list. + +B<NOTE:> Items B<ARE NOT> blessed when added. + +=item $e->set_uuid($UUID) + +Inherited from L<Test2::Event>, overridden to also vivify/mutate the 'about' +facet. + +=item $e->set_trace($trace) + +Inherited from L<Test2::Event> which allows you to change the trace. + +B<Note:> This method does not bless/clone the trace for you. Many things will +expect the trace to be blessed, so you should probably do that. + +=back + +=head2 LEGACY SUPPORT METHODS + +These are all imported from L<Test2::Util::Facets2Legacy>, see that module or +L<Test2::Event> for documentation on what they do. + +=over 4 + +=item causes_fail + +=item diagnostics + +=item global + +=item increments_count + +=item no_display + +=item sets_plan + +=item subtest_id + +=item summary + +=item terminate + +=back + +=head1 THIRD PARTY META-DATA + +This object consumes L<Test2::Util::ExternalMeta> 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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Waiting.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Waiting.pm new file mode 100644 index 0000000000..58b583fd5e --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Event/Waiting.pm @@ -0,0 +1,76 @@ +package Test2::Event::Waiting; +use strict; +use warnings; + +our $VERSION = '1.302133'; + + +BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } +use Test2::Util::HashBase; + +sub global { 1 }; + +sub summary { "IPC is waiting for children to finish..." } + +sub facet_data { + my $self = shift; + + my $out = $self->common_facet_data; + + push @{$out->{info}} => { + tag => 'INFO', + debug => 0, + details => $self->summary, + }; + + return $out; +} + +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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet.pm new file mode 100644 index 0000000000..619d369120 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet.pm @@ -0,0 +1,93 @@ +package Test2::EventFacet; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +use Test2::Util::HashBase qw/-details/; +use Carp qw/croak/; + +my $SUBLEN = length(__PACKAGE__ . '::'); +sub facet_key { + my $key = ref($_[0]) || $_[0]; + substr($key, 0, $SUBLEN, ''); + return lc($key); +} + +sub is_list { 0 } + +sub clone { + my $self = shift; + my $type = ref($self); + return bless {%$self, @_}, $type; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet - Base class for all event facets. + +=head1 DESCRIPTION + +Base class for all event facets. + +=head1 METHODS + +=over 4 + +=item $key = $facet_class->facet_key() + +This will return the key for the facet in the facet data hash. + +=item $bool = $facet_class->is_list() + +This will return true if the facet should be in a list instead of a single +item. + +=item $clone = $facet->clone() + +=item $clone = $facet->clone(%replace) + +This will make a shallow clone of the facet. You may specify fields to override +as arguments. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/About.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/About.pm new file mode 100644 index 0000000000..fe1d30eca0 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/About.pm @@ -0,0 +1,86 @@ +package Test2::EventFacet::About; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{ -package -no_display -uuid }; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::About - Facet with event details. + +=head1 DESCRIPTION + +This facet has information about the event, such as event package. + +=head1 FIELDS + +=over 4 + +=item $string = $about->{details} + +=item $string = $about->details() + +Summary about the event. + +=item $package = $about->{package} + +=item $package = $about->package() + +Event package name. + +=item $bool = $about->{no_display} + +=item $bool = $about->no_display() + +True if the event should be skipped by formatters. + +=item $uuid = $about->{uuid} + +=item $uuid = $about->uuid() + +Will be set to a uuid if uuid tagging was enabled. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Amnesty.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Amnesty.pm new file mode 100644 index 0000000000..9ef227f166 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Amnesty.pm @@ -0,0 +1,91 @@ +package Test2::EventFacet::Amnesty; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +sub is_list { 1 } + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{ -tag -inherited }; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Amnesty - Facet for assertion amnesty. + +=head1 DESCRIPTION + +This package represents what is expected in units of amnesty. + +=head1 NOTES + +This facet appears in a list instead of being a single item. + +=head1 FIELDS + +=over 4 + +=item $string = $amnesty->{details} + +=item $string = $amnesty->details() + +Human readable explanation of why amnesty was granted. + +Example: I<Not implemented yet, will fix> + +=item $short_string = $amnesty->{tag} + +=item $short_string = $amnesty->tag() + +Short string (usually 10 characters or less, not enforced, but may be truncated +by renderers) categorizing the amnesty. + +=item $bool = $amnesty->{inherited} + +=item $bool = $amnesty->inherited() + +This will be true if the amnesty was granted to a parent event and inherited by +this event, which is a child, such as an assertion within a subtest that is +marked todo. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Assert.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Assert.pm new file mode 100644 index 0000000000..090860aa0b --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Assert.pm @@ -0,0 +1,93 @@ +package Test2::EventFacet::Assert; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{ -pass -no_debug -number }; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Assert - Facet representing an assertion. + +=head1 DESCRIPTION + +The assertion facet is provided by any event representing an assertion that was +made. + +=head1 FIELDS + +=over 4 + +=item $string = $assert->{details} + +=item $string = $assert->details() + +Human readable description of the assertion. + +=item $bool = $assert->{pass} + +=item $bool = $assert->pass() + +True if the assertion passed. + +=item $bool = $assert->{no_debug} + +=item $bool = $assert->no_debug() + +Set this to true if you have provided custom diagnostics and do not want the +defaults to be displayed. + +=item $int = $assert->{number} + +=item $int = $assert->number() + +(Optional) assertion number. This may be omitted or ignored. This is usually +only useful when parsing/processing TAP. + +B<Note>: This is not set by the Test2 system, assertion number is not known +until AFTER the assertion has been processed. This attribute is part of the +spec only for harnesses. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Control.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Control.pm new file mode 100644 index 0000000000..b52718df55 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Control.pm @@ -0,0 +1,100 @@ +package Test2::EventFacet::Control; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{ -global -terminate -halt -has_callback -encoding }; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Control - Facet for hub actions and behaviors. + +=head1 DESCRIPTION + +This facet is used when the event needs to give instructions to the Test2 +internals. + +=head1 FIELDS + +=over 4 + +=item $string = $control->{details} + +=item $string = $control->details() + +Human readable explanation for the special behavior. + +=item $bool = $control->{global} + +=item $bool = $control->global() + +True if the event is global in nature and should be seen by all hubs. + +=item $exit = $control->{terminate} + +=item $exit = $control->terminate() + +Defined if the test should immediately exit, the value is the exit code and may +be C<0>. + +=item $bool = $control->{halt} + +=item $bool = $control->halt() + +True if all testing should be halted immediately. + +=item $bool = $control->{has_callback} + +=item $bool = $control->has_callback() + +True if the C<callback($hub)> method on the event should be called. + +=item $encoding = $control->{encoding} + +=item $encoding = $control->encoding() + +This can be used to change the encoding from this event onward. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Error.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Error.pm new file mode 100644 index 0000000000..306dc310d8 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Error.pm @@ -0,0 +1,93 @@ +package Test2::EventFacet::Error; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +sub facet_key { 'errors' } +sub is_list { 1 } + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{ -tag -fail }; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Error - Facet for errors that need to be shown. + +=head1 DESCRIPTION + +This facet is used when an event needs to convey errors. + +=head1 NOTES + +This facet has the hash key C<'errors'>, and is a list of facets instead of a +single item. + +=head1 FIELDS + +=over 4 + +=item $string = $error->{details} + +=item $string = $error->details() + +Explanation of the error, or the error itself (such as an exception). In perl +exceptions may be blessed objects, so this field may contain a blessed object. + +=item $short_string = $error->{tag} + +=item $short_string = $error->tag() + +Short tag to categorize the error. This is usually 10 characters or less, +formatters may truncate longer tags. + +=item $bool = $error->{fail} + +=item $bool = $error->fail() + +Not all errors are fatal, some are displayed having already been handled. Set +this to true if you want the error to cause the test to fail. Without this the +error is simply a diagnostics message that has no effect on the overall +pass/fail result. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Hub.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Hub.pm new file mode 100644 index 0000000000..03c5553054 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Hub.pm @@ -0,0 +1,109 @@ +package Test2::EventFacet::Hub; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +sub is_list { 1 } +sub facet_key { 'hubs' } + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{-pid -tid -hid -nested -buffered -uuid -ipc}; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Hub + +=head1 DESCRIPTION + +These are a record of the hubs an event passes through. Most recent hub is the +first one in the list. + +=head1 FACET FIELDS + +=over 4 + +=item $string = $trace->{details} + +=item $string = $trace->details() + +The hub class or subclass + +=item $int = $trace->{pid} + +=item $int = $trace->pid() + +PID of the hub this event was sent to. + +=item $int = $trace->{tid} + +=item $int = $trace->tid() + +The thread ID of the hub the event was sent to. + +=item $hid = $trace->{hid} + +=item $hid = $trace->hid() + +The ID of the hub that the event was send to. + +=item $huuid = $trace->{huuid} + +=item $huuid = $trace->huuid() + +The UUID of the hub that the event was sent to. + +=item $int = $trace->{nested} + +=item $int = $trace->nested() + +How deeply nested the hub was. + +=item $bool = $trace->{buffered} + +=item $bool = $trace->buffered() + +True if the event was buffered and not sent to the formatter independent of a +parent (This should never be set when nested is C<0> or C<undef>). + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Info.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Info.pm new file mode 100644 index 0000000000..805cab1ba9 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Info.pm @@ -0,0 +1,102 @@ +package Test2::EventFacet::Info; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +sub is_list { 1 } + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{-tag -debug -important}; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Info - Facet for information a developer might care about. + +=head1 DESCRIPTION + +This facet represents messages intended for humans that will help them either +understand a result, or diagnose a failure. + +=head1 NOTES + +This facet appears in a list instead of being a single item. + +=head1 FIELDS + +=over 4 + +=item $string_or_structure = $info->{details} + +=item $string_or_structure = $info->details() + +Human readable string or data structure, this is the information to display. +Formatters are free to render the structures however they please. This may +contain a blessed object. + +=item $short_string = $info->{tag} + +=item $short_string = $info->tag() + +Short tag to categorize the info. This is usually 10 characters or less, +formatters may truncate longer tags. + +=item $bool = $info->{debug} + +=item $bool = $info->debug() + +Set this to true if the message is critical, or explains a failure. This is +info that should be displayed by formatters even in less-verbose modes. + +When false the information is not considered critical and may not be rendered +in less-verbose modes. + +=item $bool = $info->{important} + +=item $bool = $info->important + +This should be set for non debug messages that are still important enough to +show when a formatter is in quiet mode. A formatter should send these to STDOUT +not STDERR, but should show them even in non-verbose mode. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Meta.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Meta.pm new file mode 100644 index 0000000000..31a4e0c1f8 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Meta.pm @@ -0,0 +1,104 @@ +package Test2::EventFacet::Meta; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use vars qw/$AUTOLOAD/; + +# replace set_details +{ + no warnings 'redefine'; + sub set_details { $_[0]->{'set_details'} } +} + +sub can { + my $self = shift; + my ($name) = @_; + + my $existing = $self->SUPER::can($name); + return $existing if $existing; + + # Only vivify when called on an instance, do not vivify for a class. There + # are a lot of magic class methods used in things like serialization (or + # the forks.pm module) which cause problems when vivified. + return undef unless ref($self); + + my $sub = sub { $_[0]->{$name} }; + { + no strict 'refs'; + *$name = $sub; + } + + return $sub; +} + +sub AUTOLOAD { + my $name = $AUTOLOAD; + $name =~ s/^.*:://g; + my $sub = $_[0]->can($name); + goto &$sub; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Meta - Facet for meta-data + +=head1 DESCRIPTION + +This facet can contain any random meta-data that has been attached to the +event. + +=head1 METHODS AND FIELDS + +Any/all fields and accessors are autovivified into existence. There is no way +to know what metadata may be added, so any is allowed. + +=over 4 + +=item $anything = $meta->{anything} + +=item $anything = $meta->anything() + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Parent.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Parent.pm new file mode 100644 index 0000000000..baf66e99a6 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Parent.pm @@ -0,0 +1,98 @@ +package Test2::EventFacet::Parent; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +use Carp qw/confess/; + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{ -hid -children -buffered }; + +sub init { + confess "Attribute 'hid' must be set" + unless defined $_[0]->{+HID}; + + $_[0]->{+CHILDREN} ||= []; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Parent - Base class for all event facets. + +=head1 DESCRIPTION + +This facet is used when an event contains other events, such as a subtest. + +=head1 FIELDS + +=over 4 + +=item $string = $parent->{details} + +=item $string = $parent->details() + +Human readable description of the event. + +=item $hid = $parent->{hid} + +=item $hid = $parent->hid() + +Hub ID of the hub that is represented in the parent-child relationship. + +=item $arrayref = $parent->{children} + +=item $arrayref = $parent->children() + +Arrayref containing the facet-data hashes of events nested under this one. + +I<To get the actual events you need to get them from the parent event directly> + +=item $bool = $parent->{buffered} + +=item $bool = $parent->buffered() + +True if the subtest is buffered (meaning the formatter has probably not seen +them yet). + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Plan.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Plan.pm new file mode 100644 index 0000000000..3789bcb5c9 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Plan.pm @@ -0,0 +1,94 @@ +package Test2::EventFacet::Plan; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{ -count -skip -none }; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Plan - Facet for setting the plan + +=head1 DESCRIPTION + +Events use this facet when they need to set the plan. + +=head1 FIELDS + +=over 4 + +=item $string = $plan->{details} + +=item $string = $plan->details() + +Human readable explanation for the plan being set. This is normally not +rendered by most formatters except when the C<skip> field is also set. + +=item $positive_int = $plan->{count} + +=item $positive_int = $plan->count() + +Set the number of expected assertions. This should usually be set to C<0> when +C<skip> or C<none> are also set. + +=item $bool = $plan->{skip} + +=item $bool = $plan->skip() + +When true the entire test should be skipped. This is usually paired with an +explanation in the C<details> field, and a C<control> facet that has +C<terminate> set to C<0>. + +=item $bool = $plan->{none} + +=item $bool = $plan->none() + +This is mainly used by legacy L<Test::Builder> tests which set the plan to C<no +plan>, a construct that predates the much better C<done_testing()>. + +If you are using this in non-legacy code you may need to reconsider the course +of your life, maybe a hermitage would suite you? + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Render.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Render.pm new file mode 100644 index 0000000000..709a9f6182 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Render.pm @@ -0,0 +1,106 @@ +package Test2::EventFacet::Render; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +sub is_list { 1 } + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } +use Test2::Util::HashBase qw{ -tag -facet -mode }; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Render - Facet that dictates how to render an event. + +=head1 DESCRIPTION + +This facet is used to dictate how the event should be rendered by the standard +test2 rendering tools. If this facet is present then ONLY what is specified by +it will be rendered. It is assumed that anything important or note-worthy will +be present here, no other facets will be considered for rendering/display. + +This facet is a list type, you can add as many items as needed. + +=head1 FIELDS + +=over 4 + +=item $string = $render->[#]->{details} + +=item $string = $render->[#]->details() + +Human readable text for display. + +=item $string = $render->[#]->{tag} + +=item $string = $render->[#]->tag() + +Tag that should prefix/identify the main text. + +=item $string = $render->[#]->{facet} + +=item $string = $render->[#]->facet() + +Optional, if the display text was generated from another facet this should +state what facet it was. + +=item $mode = $render->[#]->mode{} + +=item $mode = $render->[#]->mode() + +=over 4 + +=item calculated + +Calculated means the facet was generated from another facet. Calculated facets +may be cleared and regenerated whenever the event state changes. + +=item replace + +Replace means the facet is intended to replace the normal rendering of the +event. + +=back + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Trace.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Trace.pm new file mode 100644 index 0000000000..280258c6aa --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/EventFacet/Trace.pm @@ -0,0 +1,280 @@ +package Test2::EventFacet::Trace; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } + +use Test2::Util qw/get_tid pkg_to_file/; +use Carp qw/confess/; + +use Test2::Util::HashBase qw{^frame ^pid ^tid ^cid -hid -nested details -buffered -uuid -huuid}; + +{ + no warnings 'once'; + *DETAIL = \&DETAILS; + *detail = \&details; + *set_detail = \&set_details; +} + +sub init { + confess "The 'frame' attribute is required" + unless $_[0]->{+FRAME}; + + $_[0]->{+DETAILS} = delete $_[0]->{detail} if $_[0]->{detail}; + + $_[0]->{+PID} = $$ unless defined $_[0]->{+PID}; + $_[0]->{+TID} = get_tid() unless defined $_[0]->{+TID}; +} + +sub snapshot { + my ($orig, @override) = @_; + bless {%$orig, @override}, __PACKAGE__; +} + +sub signature { + my $self = shift; + + # Signature is only valid if all of these fields are defined, there is no + # signature if any is missing. '0' is ok, but '' is not. + return join ':' => map { (defined($_) && length($_)) ? $_ : return undef } ( + $self->{+CID}, + $self->{+PID}, + $self->{+TID}, + $self->{+FRAME}->[1], + $self->{+FRAME}->[2], + ); +} + +sub debug { + my $self = shift; + return $self->{+DETAILS} if $self->{+DETAILS}; + 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] } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::EventFacet::Trace - Debug information for events + +=head1 DESCRIPTION + +The L<Test2::API::Context> object, as well as all L<Test2::Event> types need to +have access to information about where they were created. This object +represents that information. + +=head1 SYNOPSIS + + use Test2::EventFacet::Trace; + + my $trace = Test2::EventFacet::Trace->new( + frame => [$package, $file, $line, $subname], + ); + +=head1 FACET FIELDS + +=over 4 + +=item $string = $trace->{details} + +=item $string = $trace->details() + +Used as a custom trace message that will be used INSTEAD of +C<< at <FILE> line <LINE> >> when calling C<< $trace->debug >>. + +=item $frame = $trace->{frame} + +=item $frame = $trace->frame() + +Get the call frame arrayref. + +=item $int = $trace->{pid} + +=item $int = $trace->pid() + +The process ID in which the event was generated. + +=item $int = $trace->{tid} + +=item $int = $trace->tid() + +The thread ID in which the event was generated. + +=item $id = $trace->{cid} + +=item $id = $trace->cid() + +The ID of the context that was used to create the event. + +=item $uuid = $trace->{uuid} + +=item $uuid = $trace->uuid() + +The UUID of the context that was used to create the event. (If uuid tagging was +enabled) + +=back + +=head2 DISCOURAGED HUB RELATED FIELDS + +These fields were not always set properly by tools. These are B<MOSTLY> +deprecated by the L<Test2::EventFacet::Hub> facets. These fields are not +required, and may only reflect the hub that was current when the event was +created, which is not necessarily the same as the hub the event was sent +through. + +Some tools did do a good job setting these to the correct hub, but you cannot +always rely on that. Use the 'hubs' facet list instead. + +=over 4 + +=item $hid = $trace->{hid} + +=item $hid = $trace->hid() + +The ID of the hub that was current when the event was created. + +=item $huuid = $trace->{huuid} + +=item $huuid = $trace->huuid() + +The UUID of the hub that was current when the event was created. (If uuid +tagging was enabled). + +=item $int = $trace->{nested} + +=item $int = $trace->nested() + +How deeply nested the event is. + +=item $bool = $trace->{buffered} + +=item $bool = $trace->buffered() + +True if the event was buffered and not sent to the formatter independent of a +parent (This should never be set when nested is C<0> or C<undef>). + +=back + +=head1 METHODS + +B<Note:> All facet frames are also 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 <FILE> line <LINE> >> when calling C<< $trace->debug >>. + +C<detail()> is an alias to the C<details> facet field for backwards +compatibility. + +=item $str = $trace->debug + +Typically returns the string C<< at <FILE> line <LINE> >>. If C<detail> 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 ($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 $sig = trace->signature + +Get a signature string that identifies this trace. This is used to check if +multiple events are related. + +If UUID's are enabled then a uuid is returned. Otherwise the signature includes +pid, tid, file, line number, and the cid which is C<'C\d+'> for traces created +by a context, or C<'T\d+'> for traces created by C<new()>. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Formatter.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Formatter.pm new file mode 100644 index 0000000000..0f179e59bc --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Formatter.pm @@ -0,0 +1,145 @@ +package Test2::Formatter; +use strict; +use warnings; + +our $VERSION = '1.302133'; + + +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 new_root { + my $class = shift; + return $class->new(@_); +} + +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<write($event, $num)> 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 { } + + sub new_root { + my $class = shift; + ... + $class->new(@_); + } + + 1; + +The C<write> 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 event is not itself an assertion. The assertion number may be any integer 0 +or greater, and may be undefined in some cases. + +The C<hide_buffered()> 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<Test2::API/"run_subtest(...)"> for more information. + +The C<terminate> and C<finalize> 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<terminate> method is called when an event's C<terminate> method returns +true, for example when a L<Test2::Event::Plan> has a C<'skip_all'> plan, or +when a L<Test2::Event::Bail> event is sent. The C<terminate> method is passed +a single argument, the L<Test2::Event> object which triggered the terminate. + +The C<finalize> method is always the last thing called on the formatter, I<< +except when C<terminate> is called for a Bail event >>. It is passed the +following arguments: + +The C<new_root> method is called when C<Test2::API::Stack> Initializes the root +hub for the first time. Most formatters will simply have this call C<< +$class->new >>, which is the default behavior. Some formatters however may want +to take extra action during construction of the root formatter, this is where +they can do that. + +=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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Formatter/TAP.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Formatter/TAP.pm new file mode 100644 index 0000000000..2082de7b8f --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Formatter/TAP.pm @@ -0,0 +1,487 @@ +package Test2::Formatter::TAP; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +use Test2::Util qw/clone_io/; + +use Test2::Util::HashBase qw{ + no_numbers handles _encoding _last_fh + -made_assertion +}; + +sub OUT_STD() { 0 } +sub OUT_ERR() { 1 } + +BEGIN { require Test2::Formatter; our @ISA = qw(Test2::Formatter) } + +sub _autoflush { + my($fh) = pop; + my $old_fh = select $fh; + $| = 1; + select $old_fh; +} + +_autoflush(\*STDOUT); +_autoflush(\*STDERR); + +sub hide_buffered { 1 } + +sub init { + my $self = shift; + + $self->{+HANDLES} ||= $self->_open_handles; + if(my $enc = delete $self->{encoding}) { + $self->encoding($enc); + } +} + +sub _open_handles { + my $self = shift; + + require Test2::API; + my $out = clone_io(Test2::API::test2_stdout()); + my $err = clone_io(Test2::API::test2_stderr()); + + _autoflush($out); + _autoflush($err); + + return [$out, $err]; +} + +sub encoding { + my $self = shift; + + if ($] ge "5.007003" and @_) { + 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, $f) = @_; + + # The most common case, a pass event with no amnesty and a normal name. + return if $self->print_optimal_pass($e, $num); + + $f ||= $e->facet_data; + + $self->encoding($f->{control}->{encoding}) if $f->{control}->{encoding}; + + my @tap = $self->event_tap($f, $num) or return; + + $self->{+MADE_ASSERTION} = 1 if $f->{assert}; + + my $nesting = $f->{trace}->{nested} || 0; + my $handles = $self->{+HANDLES}; + 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; + + print $io "\n" + if $ENV{HARNESS_ACTIVE} + && !$ENV{HARNESS_IS_VERBOSE} + && $hid == OUT_ERR + && $self->{+_LAST_FH} != $io + && $msg =~ m/^#\s*Failed test /; + + $msg =~ s/^/$indent/mg if $nesting; + print $io $msg; + $self->{+_LAST_FH} = $io; + } +} + +sub print_optimal_pass { + my ($self, $e, $num) = @_; + + my $type = ref($e); + + # Only optimal if this is a Pass or a passing Ok + return unless $type eq 'Test2::Event::Pass' || ($type eq 'Test2::Event::Ok' && $e->{pass}); + + # Amnesty requires further processing (todo is a form of amnesty) + return if ($e->{amnesty} && @{$e->{amnesty}}) || defined($e->{todo}); + + # A name with a newline or hash symbol needs extra processing + return if defined($e->{name}) && (-1 != index($e->{name}, "\n") || -1 != index($e->{name}, '#')); + + my $ok = 'ok'; + $ok .= " $num" if $num && !$self->{+NO_NUMBERS}; + $ok .= defined($e->{name}) ? " - $e->{name}\n" : "\n"; + + if (my $nesting = $e->{trace}->{nested}) { + my $indent = ' ' x $nesting; + $ok = "$indent$ok"; + } + + my $io = $self->{+HANDLES}->[OUT_STD]; + + local($\, $,) = (undef, '') if $\ || $,; + print $io $ok; + $self->{+_LAST_FH} = $io; + + return 1; +} + +sub event_tap { + my ($self, $f, $num) = @_; + + my @tap; + + # If this IS the first event the plan should come first + # (plan must be before or after assertions, not in the middle) + push @tap => $self->plan_tap($f) if $f->{plan} && !$self->{+MADE_ASSERTION}; + + # The assertion is most important, if present. + if ($f->{assert}) { + push @tap => $self->assert_tap($f, $num); + push @tap => $self->debug_tap($f, $num) unless $f->{assert}->{no_debug} || $f->{assert}->{pass}; + } + + # Almost as important as an assertion + push @tap => $self->error_tap($f) if $f->{errors}; + + # Now lets see the diagnostics messages + push @tap => $self->info_tap($f) if $f->{info}; + + # If this IS NOT the first event the plan should come last + # (plan must be before or after assertions, not in the middle) + push @tap => $self->plan_tap($f) if $self->{+MADE_ASSERTION} && $f->{plan}; + + # Bail out + push @tap => $self->halt_tap($f) if $f->{control}->{halt}; + + return @tap if @tap; + return @tap if $f->{control}->{halt}; + return @tap if grep { $f->{$_} } qw/assert plan info errors/; + + # Use the summary as a fallback if nothing else is usable. + return $self->summary_tap($f, $num); +} + +sub error_tap { + my $self = shift; + my ($f) = @_; + + my $IO = ($f->{amnesty} && @{$f->{amnesty}}) ? OUT_STD : OUT_ERR; + + return map { + my $details = $_->{details}; + + my $msg; + if (ref($details)) { + require Data::Dumper; + my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1); + chomp($msg = $dumper->Dump); + } + else { + chomp($msg = $details); + $msg =~ s/^/# /; + $msg =~ s/\n/\n# /g; + } + + [$IO, "$msg\n"]; + } @{$f->{errors}}; +} + +sub plan_tap { + my $self = shift; + my ($f) = @_; + my $plan = $f->{plan} or return; + + return if $plan->{none}; + + if ($plan->{skip}) { + my $reason = $plan->{details} or return [OUT_STD, "1..0 # SKIP\n"]; + chomp($reason); + return [OUT_STD, '1..0 # SKIP ' . $reason . "\n"]; + } + + return [OUT_STD, "1.." . $plan->{count} . "\n"]; +} + +sub no_subtest_space { 0 } +sub assert_tap { + my $self = shift; + my ($f, $num) = @_; + + my $assert = $f->{assert} or return; + my $pass = $assert->{pass}; + my $name = $assert->{details}; + + my $ok = $pass ? 'ok' : 'not ok'; + $ok .= " $num" if $num && !$self->{+NO_NUMBERS}; + + # 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 $extra_space = @extra ? ' ' x (length($ok) + 2) : ''; + my $extra_indent = ''; + + my ($directives, $reason, $is_skip); + if ($f->{amnesty}) { + my %directives; + + for my $am (@{$f->{amnesty}}) { + next if $am->{inherited}; + my $tag = $am->{tag} or next; + $is_skip = 1 if $tag eq 'skip'; + + $directives{$tag} ||= $am->{details}; + } + + my %seen; + my @order = grep { !$seen{$_}++ } sort keys %directives; + + $directives = ' # ' . join ' & ' => @order; + + for my $tag ('skip', @order) { + next unless defined($directives{$tag}) && length($directives{$tag}); + $reason = $directives{$tag}; + last; + } + } + + $ok .= " - $name" if defined $name && !($is_skip && !$name); + + my @subtap; + if ($f->{parent} && $f->{parent}->{buffered}) { + $ok .= ' {'; + + # In a verbose harness we indent the extra 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} || !$ENV{HARNESS_ACTIVE}) { + $extra_indent = " "; + $extra_space = ' '; + } + + # Render the sub-events, we use our own counter for these. + my $count = 0; + @subtap = map { + my $f2 = $_; + + # Bump the count for any event that should bump it. + $count++ if $f2->{assert}; + + # 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($f2, $count); + } @{$f->{parent}->{children}}; + + push @subtap => [OUT_STD, "}\n"]; + } + + if ($directives) { + $directives = ' # TODO & SKIP' if $directives eq ' # TODO & skip'; + $ok .= $directives; + $ok .= " $reason" if defined($reason); + } + + $extra_space = ' ' if $self->no_subtest_space; + + my @out = ([OUT_STD, "$ok\n"]); + push @out => map {[OUT_STD, "${extra_indent}#${extra_space}$_\n"]} @extra if @extra; + push @out => @subtap; + + return @out; +} + +sub debug_tap { + my ($self, $f, $num) = @_; + + # 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 = $f->{assert}->{details}; + my $trace = $f->{trace}; + + my $debug = "[No trace info available]"; + if ($trace->{details}) { + $debug = $trace->{details}; + } + elsif ($trace->{frame}) { + my ($pkg, $file, $line) = @{$trace->{frame}}; + $debug = "at $file line $line." if $file && $line; + } + + my $amnesty = $f->{amnesty} && @{$f->{amnesty}} + ? ' (with amnesty)' + : ''; + + # 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[# Failed test${amnesty} '$name'\n# $debug\n] + : qq[# Failed test${amnesty} $debug\n]; + + my $IO = $f->{amnesty} && @{$f->{amnesty}} ? OUT_STD : OUT_ERR; + + return [$IO, $msg]; +} + +sub halt_tap { + my ($self, $f) = @_; + + return if $f->{trace}->{nested} && !$f->{trace}->{buffered}; + my $details = $f->{control}->{details}; + + return [OUT_STD, "Bail out!\n"] unless defined($details) && length($details); + return [OUT_STD, "Bail out! $details\n"]; +} + +sub info_tap { + my ($self, $f) = @_; + + return map { + my $details = $_->{details}; + + my $IO = $_->{debug} && !($f->{amnesty} && @{$f->{amnesty}}) ? OUT_ERR : OUT_STD; + + my $msg; + if (ref($details)) { + require Data::Dumper; + my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1); + chomp($msg = $dumper->Dump); + } + else { + chomp($msg = $details); + $msg =~ s/^/# /; + $msg =~ s/\n/\n# /g; + } + + [$IO, "$msg\n"]; + } @{$f->{info}}; +} + +sub summary_tap { + my ($self, $f, $num) = @_; + + return if $f->{about}->{no_display}; + + my $summary = $f->{about}->{details} or return; + chomp($summary); + $summary =~ s/^/# /smg; + + return [OUT_STD, "$summary\n"]; +} + +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<OUT_STD> and C<OUT_ERR> 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. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Kent Fredric E<lt>kentnl@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Hub.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Hub.pm new file mode 100644 index 0000000000..6be1c8d1f5 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Hub.pm @@ -0,0 +1,908 @@ +package Test2::Hub; +use strict; +use warnings; + +our $VERSION = '1.302133'; + + +use Carp qw/carp croak confess/; +use Test2::Util qw/get_tid ipc_separator/; + +use Scalar::Util qw/weaken/; +use List::Util qw/first/; + +use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; +use Test2::Util::HashBase qw{ + pid tid hid ipc + nested buffered + no_ending + _filters + _pre_filters + _listeners + _follow_ups + _formatter + _context_acquire + _context_init + _context_release + + uuid + active + count + failed + ended + bailed_out + _passing + _plan + skip_reason +}; + +my $UUID_VIA; + +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++; + + $UUID_VIA ||= Test2::API::_add_uuid_via_ref(); + $self->{+UUID} = ${$UUID_VIA}->('hub') if $$UUID_VIA; + + $self->{+NESTED} = 0 unless defined $self->{+NESTED}; + $self->{+BUFFERED} = 0 unless defined $self->{+BUFFERED}; + + $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 _tb_reset { + my $self = shift; + + # Nothing to do + return if $self->{+PID} == $$ && $self->{+TID} == get_tid(); + + $self->{+PID} = $$; + $self->{+TID} = get_tid(); + $self->{+HID} = join ipc_separator, $self->{+PID}, $self->{+TID}, $ID_POSTFIX++; + + if (my $ipc = $self->{+IPC}) { + $ipc->add_hub($self->{+HID}); + } +} + +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->{+NESTED} ||= 0; + + $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) = @_; + + $e->add_hub( + { + details => ref($self), + + buffered => $self->{+BUFFERED}, + hid => $self->{+HID}, + nested => $self->{+NESTED}, + pid => $self->{+PID}, + tid => $self->{+TID}, + uuid => $self->{+UUID}, + + ipc => $self->{+IPC} ? 1 : 0, + } + ); + + $e->set_uuid(${$UUID_VIA}->('event')) if $$UUID_VIA; + + 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; + } + } + + # Optimize the most common case + my $type = ref($e); + if ($type eq 'Test2::Event::Pass' || ($type eq 'Test2::Event::Ok' && $e->{pass})) { + my $count = ++($self->{+COUNT}); + $self->{+_FORMATTER}->write($e, $count) if $self->{+_FORMATTER}; + + if ($self->{+_LISTENERS}) { + $_->{code}->($self, $e, $count) for @{$self->{+_LISTENERS}}; + } + + return $e; + } + + my $f = $e->facet_data; + + my $fail = 0; + $fail = 1 if $f->{assert} && !$f->{assert}->{pass}; + $fail = 1 if $f->{errors} && grep { $_->{fail} } @{$f->{errors}}; + $fail = 0 if $f->{amnesty}; + + $self->{+COUNT}++ if $f->{assert}; + $self->{+FAILED}++ if $fail && $f->{assert}; + $self->{+_PASSING} = 0 if $fail; + + my $code = $f->{control}->{terminate}; + my $count = $self->{+COUNT}; + + if (my $plan = $f->{plan}) { + if ($plan->{skip}) { + $self->plan('SKIP'); + $self->set_skip_reason($plan->{details} || 1); + $code ||= 0; + } + elsif ($plan->{none}) { + $self->plan('NO PLAN'); + } + else { + $self->plan($plan->{count}); + } + } + + $e->callback($self) if $f->{control}->{has_callback}; + + $self->{+_FORMATTER}->write($e, $count, $f) if $self->{+_FORMATTER}; + + if ($self->{+_LISTENERS}) { + $_->{code}->($self, $e, $count, $f) for @{$self->{+_LISTENERS}}; + } + + if ($f->{control}->{halt}) { + $code ||= 255; + $self->set_bailed_out($e); + } + + if (defined $code) { + $self->{+_FORMATTER}->terminate($e, $f) if $self->{+_FORMATTER}; + $self->terminate($code, $e, $f); + } + + 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<send()> 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<filter()> or C<pre_filter()>, depending on your +needs. Both have identical syntax, so only C<filter()> 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<inherit> 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<inherit> 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<Test2::Formatter::TAP> 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<listen()> 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<filter> and a C<pre_filter> is that C<pre_filter> 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<filter()> or C<pre_filter()>. + +=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<Test2::EventFacet::Trace> 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<Test::Builder> and backwards compatibility. This has you +directly manipulate the hash instead of returning a new one for performance +reasons. + +B<Note> 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<Test2::API::Context> instance that was created. + +B<Note> 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<Test2::API::Context> instance that was released. These will run in reverse +order. + +B<Note> 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 $uuid = $hub->uuid() + +If UUID tagging is enabled (see L<Test2::API>) then the hub will have a UUID. + +=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<Test2::Util::ExternalMeta> 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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Hub/Interceptor.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Hub/Interceptor.pm new file mode 100644 index 0000000000..b7af4cf427 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Hub/Interceptor.pm @@ -0,0 +1,88 @@ +package Test2::Hub::Interceptor; +use strict; +use warnings; + +our $VERSION = '1.302133'; + + +use Test2::Hub::Interceptor::Terminator(); + +BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) } +use Test2::Util::HashBase; + +sub init { + my $self = shift; + $self->SUPER::init(); + $self->{+NESTED} = 0; +} + +sub inherit { + my $self = shift; + my ($from, %params) = @_; + + $self->{+NESTED} = 0; + + 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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Hub/Interceptor/Terminator.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Hub/Interceptor/Terminator.pm new file mode 100644 index 0000000000..76ad94a94c --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Hub/Interceptor/Terminator.pm @@ -0,0 +1,51 @@ +package Test2::Hub::Interceptor::Terminator; +use strict; +use warnings; + +our $VERSION = '1.302133'; + + +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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Hub/Subtest.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Hub/Subtest.pm new file mode 100644 index 0000000000..c36a19e1ad --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Hub/Subtest.pm @@ -0,0 +1,136 @@ +package Test2::Hub::Subtest; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) } +use Test2::Util::HashBase qw/nested exit_code manual_skip_all/; +use Test2::Util qw/get_tid/; + +sub is_subtest { 1 } + +sub inherit { + my $self = shift; + my ($from) = @_; + + $self->SUPER::inherit($from); + + $self->{+NESTED} = $from->nested + 1; +} + +{ + # Legacy + no warnings 'once'; + *ID = \&Test2::Hub::HID; + *id = \&Test2::Hub::hid; + *set_id = \&Test2::Hub::set_hid; +} + +sub send { + my $self = shift; + my ($e) = @_; + + my $out = $self->SUPER::send($e); + + return $out if $self->{+MANUAL_SKIP_ALL}; + + my $f = $e->facet_data; + + my $plan = $f->{plan} or return $out; + return $out unless $plan->{skip}; + + my $trace = $f->{trace} or die "Missing Trace!"; + return $out unless $trace->{pid} != $self->pid + || $trace->{tid} != $self->tid; + + no warnings 'exiting'; + last T2_SUBTEST_WRAPPER; +} + +sub terminate { + my $self = shift; + my ($code, $e, $f) = @_; + $self->set_exit_code($code); + + return if $self->{+MANUAL_SKIP_ALL}; + + $f ||= $e->facet_data; + + if(my $plan = $f->{plan}) { + my $trace = $f->{trace} or die "Missing Trace!"; + return if $plan->{skip} + && ($trace->{pid} != $$ || $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<last LABEL> 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<you> are responsible for ensuring no additional events are generated. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/IPC.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/IPC.pm new file mode 100644 index 0000000000..cfee461802 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/IPC.pm @@ -0,0 +1,149 @@ +package Test2::IPC; +use strict; +use warnings; + +our $VERSION = '1.302133'; + + +use Test2::API::Instance; +use Test2::Util qw/get_tid/; +use Test2::API qw{ + test2_init_done + test2_ipc + test2_has_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 unimport { Test2::API::test2_ipc_disable() } + +sub import { + goto &Exporter::import if test2_has_ipc || !test2_init_done(); + + confess "IPC is disabled" if Test2::API::test2_ipc_disabled(); + 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<use Test2::IPC;> 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. + +=head2 DISABLING IT + +You can use C<no Test2::IPC;> to disable IPC for good. You can also use the +T2_NO_IPC env var. + +=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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/IPC/Driver.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/IPC/Driver.pm new file mode 100644 index 0000000000..a4d7255732 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/IPC/Driver.pm @@ -0,0 +1,302 @@ +package Test2::IPC::Driver; +use strict; +use warnings; + +our $VERSION = '1.302133'; + + +use Carp qw/confess/; +use Test2::Util::HashBase qw{no_fatal no_bail}; + +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) = @_); + + $self->driver_abort($msg) if $self->can('driver_abort'); + + print STDERR "IPC Fatal Error: $msg\n"; + print STDOUT "Bail out! IPC Fatal Error: $msg\n" unless $self->no_bail; + + CORE::exit(255) unless $self->no_fatal; +} + +sub abort_trace { + my $self = shift; + my ($msg) = @_; + # Older versions of Carp do not export longmess() function, so it needs to be called with package name + $self->abort(Carp::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<Carp::longmess> 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<Test2::API>/L<Test2::API::Instance>. + +=back + +=head1 LOADING DRIVERS + +Test2::IPC::Driver has an C<import()> 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 $ipc->driver_abort($msg) + +This is a hook called by C<< Test2::IPC::Driver->abort() >>. This is your +chance to cleanup when an abort happens. You cannot prevent the abort, but you +can gracefully except it. + +=item $bool = $ipc->use_shm() + +True if you want to make use of the L<Test2::API>/L<Test2::API::Instance> 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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/IPC/Driver/Files.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/IPC/Driver/Files.pm new file mode 100644 index 0000000000..1d37a83326 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/IPC/Driver/Files.pm @@ -0,0 +1,483 @@ +package Test2::IPC::Driver::Files; +use strict; +use warnings; + +our $VERSION = '1.302133'; + + +BEGIN { require Test2::IPC::Driver; our @ISA = qw(Test2::IPC::Driver) } + +use Test2::Util::HashBase qw{tempdir event_ids read_ids timeouts 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 do_rename do_unlink try_sig_mask/; +use Test2::API qw/test2_ipc_set_pending/; + +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_IDS} = {}; + $self->{+READ_IDS} = {}; + $self->{+TIMEOUTS} = {}; + + $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 $tid = get_tid(); + my $eid = $self->{+EVENT_IDS}->{$hid}->{$$}->{$tid} += 1; + + my @type = split '::', $type; + my $name = join(ipc_separator, $hid, $$, $tid, $eid, @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}++; + } + + # Write and rename the file. + my ($ren_ok, $ren_err); + my ($ok, $err) = try_sig_mask { + Storable::store($e, $file); + ($ren_ok, $ren_err) = do_rename("$file", $ready); + }; + + if ($ok) { + $self->abort("Could not rename file '$file' -> '$ready': $ren_err") unless $ren_ok; + test2_ipc_set_pending(substr($file, -(shm_size))); + } + else { + 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 driver_abort { + my $self = shift; + my ($msg) = @_; + + local ($@, $!, $?, $^E); + eval { + my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT"); + open(my $fh, '>>', $abort) or die "Could not open abort file: $!"; + print $fh $msg, "\n"; + close($fh) or die "Could not close abort file: $!"; + 1; + } or warn $@; +} + +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 $read = $self->{+READ_IDS}; + my $timeouts = $self->{+TIMEOUTS}; + + my @out; + for my $info (sort cmp_events map { $self->should_read_event($hid, $_) } readdir($dh)) { + unless ($info->{global}) { + my $next = $self->{+READ_IDS}->{$info->{hid}}->{$info->{pid}}->{$info->{tid}} ||= 1; + + $timeouts->{$info->{file}} ||= time; + + if ($next != $info->{eid}) { + # Wait up to N seconds for missing events + next unless 5 < time - $timeouts->{$info->{file}}; + $self->abort("Missing event HID: $info->{hid}, PID: $info->{pid}, TID: $info->{tid}, EID: $info->{eid}."); + } + + $self->{+READ_IDS}->{$info->{hid}}->{$info->{pid}}->{$info->{tid}} = $info->{eid} + 1; + } + + 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 { + file => $file, + 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 '.'; + return if substr($file, 0, 3) eq 'HUB'; + CORE::exit(255) if $file eq 'ABORT'; + + 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::EventFacet::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}; + + my $aborted = 0; + my $abort_file = File::Spec->catfile($self->{+TEMPDIR}, "ABORT"); + if (-e $abort_file) { + $aborted = 1; + my ($ok, $err) = do_unlink($abort_file); + warn $err unless $ok; + } + + 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 ($aborted || $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; + } + + my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT"); + unlink($abort) if -e $abort; + 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<Test2>. 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<File::Temp>. + +=back + +=head1 SEE ALSO + +See L<Test2::IPC::Driver> for methods. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Tools/Tiny.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Tools/Tiny.pm new file mode 100644 index 0000000000..93c3df03e8 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Tools/Tiny.pm @@ -0,0 +1,435 @@ +package Test2::Tools::Tiny; +use strict; +use warnings; + +BEGIN { + if ($] lt "5.008") { + require Test::Builder::IO::Scalar; + } +} + +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.302133'; + +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(); + + return $ctx->pass_and_release($name) if $bool; + return $ctx->fail_and_release($name, @diag); +} + +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; + } + + return $ctx->pass_and_release($name) if $bool; + + $got = '*NOT DEFINED*' unless defined $got; + $want = '*NOT DEFINED*' unless defined $want; + unshift @diag => ( + "GOT: $got", + "EXPECTED: $want", + ); + + return $ctx->fail_and_release($name, @diag); +} + +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; + } + + return $ctx->pass_and_release($name) if $bool; + + unshift @diag => "Strings are the same (they should not be)" + unless $bool; + + return $ctx->fail_and_release($name, @diag); +} + +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."; + } + + return $ctx->pass_and_release($name) if $bool; + return $ctx->fail_and_release($name, @diag); +} + +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."; + } + + return $ctx->pass_and_release($name) if $bool; + return $ctx->fail_and_release($name, @diag); +} + +sub is_deeply($$;$@) { + my ($got, $want, $name, @diag) = @_; + my $ctx = context(); + + no warnings 'once'; + require Data::Dumper; + + # Otherwise numbers might be unquoted + local $Data::Dumper::Useperl = 1; + + 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; + + return $ctx->pass_and_release($name) if $bool; + return $ctx->fail_and_release($name, $g, $w, @diag); +} + +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) = @_; + if ($active_hub == $hub) { + $event->set_todo($reason) if $event->can('set_todo'); + $event->add_amnesty({tag => 'TODO', details => $reason}); + } + else { + $event->add_amnesty({tag => 'TODO', details => $reason, inherited => 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(); + + my $be = caller->can('before_each'); + + $be->($name) if $be; + + 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 { + # Scalar refs as filehandles were added in 5.8. + if ($] ge "5.008") { + open($out_fh, '>', \$out) or die "Failed to open a temporary STDOUT: $!"; + open($err_fh, '>', \$err) or die "Failed to open a temporary STDERR: $!"; + } + # Emulate scalar ref filehandles with a tie. + else { + $out_fh = Test::Builder::IO::Scalar->new(\$out) or die "Failed to open a temporary STDOUT"; + $err_fh = Test::Builder::IO::Scalar->new(\$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<Test2::Suite>. + +=head1 DESCRIPTION + +You should really look at L<Test2::Suite>. This package is some very basic +essential tools implemented using L<Test2>. This exists only so that L<Test2> +and other tools required by L<Test2::Suite> can be tested. This is the package +L<Test2> uses to test itself. + +=head1 USE Test2::Suite INSTEAD + +Use L<Test2::Suite> 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<DUMB> implementation that +compares the output of L<Data::Dumper> 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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Transition.pod b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Transition.pod new file mode 100644 index 0000000000..12c46ee569 --- /dev/null +++ b/systems/texlive/tlnet/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<Test2::API> 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<Test2::API> 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<Test::Aggregate> is in +the dependency chain. + +See the L<Test::Aggregate> 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<Test2::IPC> 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 + +=item Test::More::Prefix + +Worked by applying a role that wrapped C<< Test::Builder->_print_comment >>. +Fixed by adding an event filter that modifies the message instead when running +under Test2. + +Fixed in version: 0.007 + +=back + +=head2 STILL BROKEN + +=over 4 + +=item Test::Aggregate + +This distribution directly accesses the hash keys in the L<Test::Builder> +singleton. It also approaches the problem from the wrong angle, please consider +using L<Test2::Harness> or L<App::ForkProve> 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<Test::Builder> singleton. This +module is also obsolete thanks to the benefits of L<Test2>. Use C<intercept()> +from L<Test2::API> to achieve a similar result. + +Still broken as of version: 0.3.0 + +=item Test::ParallelSubtest + +This module overrides C<Test::Builder::subtest()> and +C<Test::Builder::done_testing()>. It also directly accesses hash elements of +the singleton. It has not yet been fixed. + +Alternatives: L<Test2::AsyncSubtest> and L<Test2::Workflow> (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 Net::BitTorrent + +The tests for this module directly access L<Test::Builder> 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<is>, C<like>, and others, see +L<Test2::Suite>. + +=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<ok>, to anything C<ok> 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<Test2::Plugin::UTF8> plugin, which is +part of L<Test2::Suite>. + +=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) E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINER + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://www.perl.com/perl/misc/Artistic.html> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Util.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Util.pm new file mode 100644 index 0000000000..6de008b683 --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Util.pm @@ -0,0 +1,419 @@ +package Test2::Util; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +use POSIX(); +use Config qw/%Config/; +use Carp qw/croak/; + +BEGIN { + local ($@, $!, $SIG{__DIE__}); + *HAVE_PERLIO = eval { require PerlIO; PerlIO->VERSION(1.02); } ? sub() { 1 } : sub() { 0 }; +} + +our @EXPORT_OK = qw{ + try + + pkg_to_file + + get_tid USE_THREADS + CAN_THREAD + CAN_REALLY_FORK + CAN_FORK + + CAN_SIGSYS + + IS_WIN32 + + ipc_separator + + do_rename do_unlink + + try_sig_mask + + clone_io +}; +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() { "~" } + +sub _check_for_sig_sys { + my $sig_list = shift; + return $sig_list =~ m/\bSYS\b/; +} + +BEGIN { + if (_check_for_sig_sys($Config{sig_name})) { + *CAN_SIGSYS = sub() { 1 }; + } + else { + *CAN_SIGSYS = sub() { 0 }; + } +} + +my %PERLIO_SKIP = ( + unix => 1, + via => 1, +); + +sub clone_io { + my ($fh) = @_; + my $fileno = fileno($fh); + + return $fh if !defined($fileno) || !length($fileno) || $fileno < 0; + + open(my $out, '>&' . $fileno) or die "Can't dup fileno $fileno: $!"; + + my %seen; + my @layers = HAVE_PERLIO ? grep { !$PERLIO_SKIP{$_} and !$seen{$_}++ } PerlIO::get_layers($fh) : (); + binmode($out, join(":", "", "raw", @layers)); + + my $old = select $fh; + my $af = $|; + select $out; + $| = $af; + select $old; + + return $out; +} + +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 try_sig_mask(&) { + my $code = shift; + + 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. + } + + my ($ok, $err) = &try($code); + + # If our block was successful we want to restore the old mask. + POSIX::sigprocmask(POSIX::SIG_SETMASK(), $old, POSIX::SigSet->new()) if defined $blocked; + + return ($ok, $err); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util - Tools used by Test2 and friends. + +=head1 DESCRIPTION + +Collection of tools used by L<Test2> 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. + +=item ($ok, $err) = do_rename($old_name, $new_name) + +Rename a file, this wraps C<rename()> in a way that makes it more reliable +cross-platform when trying to rename files you recently altered. + +=item ($ok, $err) = do_unlink($filename) + +Unlink a file, this wraps C<unlink()> in a way that makes it more reliable +cross-platform when trying to unlink files you recently altered. + +=item ($ok, $err) = try_sig_mask { ... } + +Complete an action with several signals masked, they will be unmasked at the +end allowing any signals that were intercepted to get handled. + +This is primarily used when you need to make several actions atomic (against +some signals anyway). + +Signals that are intercepted: + +=over 4 + +=item SIGINT + +=item SIGALRM + +=item SIGHUP + +=item SIGTERM + +=item SIGUSR1 + +=item SIGUSR2 + +=back + +=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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=item Kent Fredric E<lt>kentnl@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Util/ExternalMeta.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Util/ExternalMeta.pm new file mode 100644 index 0000000000..f03422c61a --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Util/ExternalMeta.pm @@ -0,0 +1,182 @@ +package Test2::Util::ExternalMeta; +use strict; +use warnings; + +our $VERSION = '1.302133'; + + +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<undef> 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<meta()> 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<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Util/Facets2Legacy.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Util/Facets2Legacy.pm new file mode 100644 index 0000000000..db74510a4d --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Util/Facets2Legacy.pm @@ -0,0 +1,299 @@ +package Test2::Util::Facets2Legacy; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +use Carp qw/croak confess/; +use Scalar::Util qw/blessed/; + +use base 'Exporter'; +our @EXPORT_OK = qw{ + causes_fail + diagnostics + global + increments_count + no_display + sets_plan + subtest_id + summary + terminate + uuid +}; +our %EXPORT_TAGS = ( ALL => \@EXPORT_OK ); + +our $CYCLE_DETECT = 0; +sub _get_facet_data { + my $in = shift; + + if (blessed($in) && $in->isa('Test2::Event')) { + confess "Cycle between Facets2Legacy and $in\->facet_data() (Did you forget to override the facet_data() method?)" + if $CYCLE_DETECT; + + local $CYCLE_DETECT = 1; + return $in->facet_data; + } + + return $in if ref($in) eq 'HASH'; + + croak "'$in' Does not appear to be either a Test::Event or an EventFacet hashref"; +} + +sub causes_fail { + my $facet_data = _get_facet_data(shift @_); + + return 1 if $facet_data->{errors} && grep { $_->{fail} } @{$facet_data->{errors}}; + + if (my $control = $facet_data->{control}) { + return 1 if $control->{halt}; + return 1 if $control->{terminate}; + } + + return 0 if $facet_data->{amnesty} && @{$facet_data->{amnesty}}; + return 1 if $facet_data->{assert} && !$facet_data->{assert}->{pass}; + return 0; +} + +sub diagnostics { + my $facet_data = _get_facet_data(shift @_); + return 1 if $facet_data->{errors} && @{$facet_data->{errors}}; + return 0 unless $facet_data->{info} && @{$facet_data->{info}}; + return (grep { $_->{debug} } @{$facet_data->{info}}) ? 1 : 0; +} + +sub global { + my $facet_data = _get_facet_data(shift @_); + return 0 unless $facet_data->{control}; + return $facet_data->{control}->{global}; +} + +sub increments_count { + my $facet_data = _get_facet_data(shift @_); + return $facet_data->{assert} ? 1 : 0; +} + +sub no_display { + my $facet_data = _get_facet_data(shift @_); + return 0 unless $facet_data->{about}; + return $facet_data->{about}->{no_display}; +} + +sub sets_plan { + my $facet_data = _get_facet_data(shift @_); + my $plan = $facet_data->{plan} or return; + my @out = ($plan->{count} || 0); + + if ($plan->{skip}) { + push @out => 'SKIP'; + push @out => $plan->{details} if defined $plan->{details}; + } + elsif ($plan->{none}) { + push @out => 'NO PLAN' + } + + return @out; +} + +sub subtest_id { + my $facet_data = _get_facet_data(shift @_); + return undef unless $facet_data->{parent}; + return $facet_data->{parent}->{hid}; +} + +sub summary { + my $facet_data = _get_facet_data(shift @_); + return '' unless $facet_data->{about} && $facet_data->{about}->{details}; + return $facet_data->{about}->{details}; +} + +sub terminate { + my $facet_data = _get_facet_data(shift @_); + return undef unless $facet_data->{control}; + return $facet_data->{control}->{terminate}; +} + +sub uuid { + my $in = shift; + + if ($CYCLE_DETECT) { + if (blessed($in) && $in->isa('Test2::Event')) { + my $meth = $in->can('uuid'); + $meth = $in->can('SUPER::uuid') if $meth == \&uuid; + my $uuid = $in->$meth if $meth && $meth != \&uuid; + return $uuid if $uuid; + } + + return undef; + } + + my $facet_data = _get_facet_data($in); + return $facet_data->{about}->{uuid} if $facet_data->{about} && $facet_data->{about}->{uuid}; + + return undef; +} + +1; + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util::Facets2Legacy - Convert facet data to the legacy event API. + +=head1 DESCRIPTION + +This module exports several subroutines from the older event API (see +L<Test2::Event>). These subroutines can be used as methods on any object that +provides a custom C<facet_data()> method. These subroutines can also be used as +functions that take a facet data hashref as arguments. + +=head1 SYNOPSIS + +=head2 AS METHODS + + package My::Event; + + use Test2::Util::Facets2Legacy ':ALL'; + + sub facet_data { return { ... } } + +Then to use it: + + my $e = My::Event->new(...); + + my $causes_fail = $e->causes_fail; + my $summary = $e->summary; + .... + +=head2 AS FUNCTIONS + + use Test2::Util::Facets2Legacy ':ALL'; + + my $f = { + assert => { ... }, + info => [{...}, ...], + control => {...}, + ... + }; + + my $causes_fail = causes_fail($f); + my $summary = summary($f); + +=head1 NOTE ON CYCLES + +When used as methods, all these subroutines call C<< $e->facet_data() >>. The +default C<facet_data()> method in L<Test2::Event> relies on the legacy methods +this module emulates in order to work. As a result of this it is very easy to +create infinite recursion bugs. + +These methods have cycle detection and will throw an exception early if a cycle +is detected. C<uuid()> is currently the only subroutine in this library that +has a fallback behavior when cycles are detected. + +=head1 EXPORTS + +Nothing is exported by default. You must specify which methods to import, or +use the ':ALL' tag. + +=over 4 + +=item $bool = $e->causes_fail() + +=item $bool = causes_fail($f) + +Check if the event or facets result in a failing state. + +=item $bool = $e->diagnostics() + +=item $bool = diagnostics($f) + +Check if the event or facets contain any diagnostics information. + +=item $bool = $e->global() + +=item $bool = global($f) + +Check if the event or facets need to be globally processed. + +=item $bool = $e->increments_count() + +=item $bool = increments_count($f) + +Check if the event or facets make an assertion. + +=item $bool = $e->no_display() + +=item $bool = no_display($f) + +Check if the event or facets should be rendered or hidden. + +=item ($max, $directive, $reason) = $e->sets_plan() + +=item ($max, $directive, $reason) = sets_plan($f) + +Check if the event or facets set a plan, and return the plan details. + +=item $id = $e->subtest_id() + +=item $id = subtest_id($f) + +Get the subtest id, if any. + +=item $string = $e->summary() + +=item $string = summary($f) + +Get the summary of the event or facets hash, if any. + +=item $undef_or_int = $e->terminate() + +=item $undef_or_int = terminate($f) + +Check if the event or facets should result in process termination, if so the +exit code is returned (which could be 0). undef is returned if no termination +is requested. + +=item $uuid = $e->uuid() + +=item $uuid = uuid($f) + +Get the UUID of the facets or event. + +B<Note:> This will fall back to C<< $e->SUPER::uuid() >> if a cycle is +detected and an event is used as the argument. + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Util/HashBase.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Util/HashBase.pm new file mode 100644 index 0000000000..8e73af425e --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Util/HashBase.pm @@ -0,0 +1,435 @@ +package Test2::Util::HashBase; +use strict; +use warnings; + +our $VERSION = '1.302133'; + +################################################################# +# # +# 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. # +# Note: You can modify the version number above this comment # +# if needed, that is fine. # +# # +################################################################# + +{ + no warnings 'once'; + $Test2::Util::HashBase::HB_VERSION = '0.006'; + *Test2::Util::HashBase::ATTR_SUBS = \%Object::HashBase::ATTR_SUBS; + *Test2::Util::HashBase::ATTR_LIST = \%Object::HashBase::ATTR_LIST; + *Test2::Util::HashBase::VERSION = \%Object::HashBase::VERSION; + *Test2::Util::HashBase::CAN_CACHE = \%Object::HashBase::CAN_CACHE; +} + + +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; + + # Make sure we list the OLDEST version used to create this class. + my $ver = $Test2::Util::HashBase::HB_VERSION || $Test2::Util::HashBase::VERSION; + $Test2::Util::HashBase::VERSION{$into} = $ver if !$Test2::Util::HashBase::VERSION{$into} || $Test2::Util::HashBase::VERSION{$into} > $ver; + + my $isa = _isa($into); + my $attr_list = $Test2::Util::HashBase::ATTR_LIST{$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}; + push @$attr_list => $x; + 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 attr_list { + my $class = shift; + + my $isa = _isa($class); + + my %seen; + my @list = grep { !$seen{$_}++ } map { + my @out; + + if (0.004 > ($Test2::Util::HashBase::VERSION{$_} || 0)) { + Carp::carp("$_ uses an inlined version of Test2::Util::HashBase too old to support attr_list()"); + } + else { + my $list = $Test2::Util::HashBase::ATTR_LIST{$_}; + @out = $list ? @$list : () + } + + @out; + } reverse @$isa; + + return @list; +} + +sub _new { + my $class = shift; + + my $self; + + if (@_ == 1) { + my $arg = shift; + my $type = ref($arg); + + if ($type eq 'HASH') { + $self = bless({%$arg}, $class) + } + else { + Carp::croak("Not sure what to do with '$type' in $class constructor") + unless $type eq 'ARRAY'; + + my %proto; + my @attributes = attr_list($class); + while (@$arg) { + my $val = shift @$arg; + my $key = shift @attributes or Carp::croak("Too many arguments for $class constructor"); + $proto{$key} = $val; + } + + $self = bless(\%proto, $class); + } + } + else { + $self = bless({@_}, $class); + } + + $Test2::Util::HashBase::CAN_CACHE{$class} = $self->can('init') + unless exists $Test2::Util::HashBase::CAN_CACHE{$class}; + + $self->init if $Test2::Util::HashBase::CAN_CACHE{$class}; + + $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; + + # These are all functionally identical + my $one = My::Class->new(foo => 'MyFoo', bar => 'MyBar'); + my $two = My::Class->new({foo => 'MyFoo', bar => 'MyBar'}); + my $three = My::Class->new(['MyFoo', '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<new()> method, as well as generating accessors you request. +Generated accessors will be getters, C<set_ACCESSOR> 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<Object::HashBase>. This file was generated using +the +C</home/exodist/perl5/perlbrew/perls/main/bin/hashbase_inc.pl> +script. + +=head1 METHODS + +=head2 PROVIDED BY HASH BASE + +=over 4 + +=item $it = $class->new(%PAIRS) + +=item $it = $class->new(\%PAIRS) + +=item $it = $class->new(\@ORDERED_VALUES) + +Create a new instance. + +HashBase will not export C<new()> if there is already a C<new()> method in your +packages inheritance chain. + +B<If you do not want this method you can define your own> you just have to +declare it before loading L<Test2::Util::HashBase>. + + 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<new()> method. +Alternatively you can define the method before loading HashBase instead of just +declaring it, but that scatters your use statements. + +The most common way to create an object is to pass in key/value pairs where +each key is an attribute and each value is what you want assigned to that +attribute. No checking is done to verify the attributes or values are valid, +you may do that in C<init()> if desired. + +If you would like, you can pass in a hashref instead of pairs. When you do so +the hashref will be copied, and the copy will be returned blessed as an object. +There is no way to ask HashBase to bless a specific hashref. + +In some cases an object may only have 1 or 2 attributes, in which case a +hashref may be too verbose for your liking. In these cases you can pass in an +arrayref with only values. The values will be assigned to attributes in the +order the attributes were listed. When there is inheritance involved the +attributes from parent classes will come before subclasses. + +=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. + +B<Note:> Test2::Util::HashBase checks for an init using C<< $class->can('init') >> +during construction. It DOES NOT call C<can()> on the created object. Also note +that the result of the check is cached, it is only ever checked once, the first +time an instance of your class is created. This means that adding an C<init()> +method AFTER the first construction will result in it being ignored. + +=back + +=head1 ACCESSORS + +=head2 READ/WRITE + +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<foo> field. + +=item set_foo() + +Setter, used to set the value of the C<foo> field. + +=item FOO() + +Constant, returns the field C<foo>'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 + +=head2 READ ONLY + + use Test2::Util::HashBase qw/-foo/; + +=over 4 + +=item set_foo() + +Throws an exception telling you the attribute is read-only. This is exported to +override any active setters for the attribute in a parent class. + +=back + +=head2 DEPRECATED SETTER + + use Test2::Util::HashBase qw/^foo/; + +=over 4 + +=item set_foo() + +This will set the value, but it will also warn you that the method is +deprecated. + +=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 GETTING A LIST OF ATTRIBUTES FOR A CLASS + +Test2::Util::HashBase provides a function for retrieving a list of attributes for an +Test2::Util::HashBase class. + +=over 4 + +=item @list = Test2::Util::HashBase::attr_list($class) + +=item @list = $class->Test2::Util::HashBase::attr_list() + +Either form above will work. This will return a list of attributes defined on +the object. This list is returned in the attribute definition order, parent +class attributes are listed before subclass attributes. Duplicate attributes +will be removed before the list is returned. + +B<Note:> This list is used in the C<< $class->new(\@ARRAY) >> constructor to +determine the attribute to which each value will be paired. + +=back + +=head1 SOURCE + +The source code repository for HashBase can be found at +F<http://github.com/Test-More/HashBase/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Util/Trace.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Util/Trace.pm new file mode 100644 index 0000000000..1e5351f6db --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/Util/Trace.pm @@ -0,0 +1,54 @@ +package Test2::Util::Trace; +require Test2::EventFacet::Trace; +@ISA = ('Test2::EventFacet::Trace'); + +our $VERSION = '1.302133'; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Util::Trace - Legacy wrapper fro L<Test2::EventFacet::Trace>. + +=head1 DESCRIPTION + +All the functionality for this class has been moved to +L<Test2::EventFacet::Trace>. + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut |