summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API
diff options
context:
space:
mode:
authorNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
committerNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
commite0c6872cf40896c7be36b11dcc744620f10adf1d (patch)
tree60335e10d2f4354b0674ec22d7b53f0f8abee672 /systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API
Initial commit
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API')
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API/Breakage.pm178
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API/Context.pm985
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API/Instance.pm916
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API/Stack.pm220
4 files changed, 2299 insertions, 0 deletions
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