diff options
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API.pm')
-rwxr-xr-x | systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API.pm | 95 |
1 files changed, 93 insertions, 2 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API.pm index 8193b07366..6c517415bd 100755 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API.pm +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Test2/API.pm @@ -9,14 +9,44 @@ BEGIN { $ENV{TEST2_ACTIVE} = 1; } -our $VERSION = '1.302162'; +our $VERSION = '1.302175'; my $INST; my $ENDING = 0; -sub test2_set_is_end { ($ENDING) = @_ ? @_ : (1) } +sub test2_unset_is_end { $ENDING = 0 } sub test2_get_is_end { $ENDING } +sub test2_set_is_end { + my $before = $ENDING; + ($ENDING) = @_ ? @_ : (1); + + # Only send the event in a transition from false to true + return if $before; + return unless $ENDING; + + return unless $INST; + my $stack = $INST->stack or return; + my $root = $stack->root or return; + + return unless $root->count; + + return unless $$ == $INST->pid; + return unless get_tid() == $INST->tid; + + my $trace = Test2::EventFacet::Trace->new( + frame => [__PACKAGE__, __FILE__, __LINE__, __PACKAGE__ . '::test2_set_is_end'], + ); + my $ctx = Test2::API::Context->new( + trace => $trace, + hub => $root, + ); + + $ctx->send_ev2(control => { phase => 'END', details => 'Transition to END phase' }); + + 1; +} + use Test2::API::Instance(\$INST); # Set the exit status @@ -85,8 +115,10 @@ our @EXPORT_OK = qw{ test2_start_preload test2_stop_preload test2_in_preload + test2_is_testing_done test2_set_is_end + test2_unset_is_end test2_get_is_end test2_pid @@ -176,6 +208,27 @@ 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_is_testing_done { + # No instance? VERY DONE! + return 1 unless $INST; + + # No stack? tests must be done, it is created pretty early + my $stack = $INST->stack or return 1; + + # Nothing on the stack, no root hub yet, likely have not started testing + return 0 unless @$stack; + + # Stack has a slot for the root hub (see above) but it is undefined, likely + # garbage collected, test is done + my $root_hub = $stack->[0] or return 1; + + # If the root hub is ended than testing is done. + return 1 if $root_hub->ended; + + # Looks like we are still testing! + return 0; +} + sub test2_no_wait { $INST->set_no_wait(@_) if @_; $INST->no_wait; @@ -322,6 +375,23 @@ sub context { my $stack = $params{stack} || $STACK; my $hub = $params{hub} || (@$stack ? $stack->[-1] : $stack->top); + + # Catch an edge case where we try to get context after the root hub has + # been garbage collected resulting in a stack that has a single undef + # hub + if (!$hub && !exists($params{hub}) && @$stack) { + my $msg = Carp::longmess("Attempt to get Test2 context after testing has completed (did you attempt a testing event after done_testing?)"); + + # The error message is usually masked by the global destruction, so we have to print to STDER + print STDERR $msg; + + # Make sure this is a failure, we are probably already in END, so set $? to change the exit code + $? = 1; + + # Now we actually die to interrupt the program flow and avoid undefined his warnings + die $msg; + } + my $hid = $hub->{hid}; my $current = $CONTEXTS->{$hid}; @@ -814,6 +884,7 @@ C<intercept { ... }> which only lets you see events as the main hub sees them. test2_ipc test2_formatter_set test2_formatter + test2_is_testing_done }; my $init = test2_init_done(); @@ -1257,6 +1328,26 @@ Check if Test2 believes it is the END phase. This will return the global L<Test2::API::Stack> instance. If this has not yet been initialized it will be initialized now. +=item $bool = test2_is_testing_done() + +This will return true if testing is complete and no other events should be +sent. This is useful in things like warning handlers where you might want to +turn warnings into events, but need them to start acting like normal warnings +when testing is done. + + $SIG{__WARN__} = sub { + my ($warning) = @_; + + if (test2_is_testing_done()) { + warn @_; + } + else { + my $ctx = context(); + ... + $ctx->release + } + } + =item test2_ipc_disable Disable IPC. |