Upgrade Test-Simple from version 1.302113 to 1.302120

8 files changed, 198 insertions, 54 deletions

diff --git a/cpan/Test-Simple/t/Legacy/subtest/callback.t b/cpan/Test-Simple/t/Legacy/subtest/callback.t
new file mode 100644
index 0000000000..097d1bf2c0
--- /dev/null
+++ b/cpan/Test-Simple/t/Legacy/subtest/callback.t
@@ -0,0 +1,53 @@
+#!/usr/bin/perl -w
+
+# What happens when a subtest dies?
+
+use lib 't/lib';
+
+use strict;
+use Test::More;
+use Test::Builder;
+use Test2::API;
+
+my $Test = Test::Builder->new;
+
+my $step = 0;
+my @callback_calls = ();
+Test2::API::test2_add_callback_pre_subtest(
+    sub {
+        $Test->is_num(
+            $step,
+            0,
+            'pre-subtest callbacks should be invoked before the subtest',
+        );
+        ++$step;
+        push @callback_calls, [@_];
+    },
+);
+
+$Test->subtest(
+    (my $subtest_name='some subtest'),
+    (my $subtest_code=sub {
+         $Test->is_num(
+             $step,
+             1,
+             'subtest should be run after the pre-subtest callbacks',
+         );
+         ++$step;
+     }),
+    (my @subtest_args = (1,2,3)),
+);
+
+is_deeply(
+    \@callback_calls,
+    [[$subtest_name,$subtest_code,@subtest_args]],
+    'pre-subtest callbacks should be invoked with the expected arguments',
+);
+
+$Test->is_num(
+    $step,
+    2,
+    'the subtest should be run',
+);
+
+$Test->done_testing();
diff --git a/cpan/Test-Simple/t/Test2/behavior/Subtest_callback.t b/cpan/Test-Simple/t/Test2/behavior/Subtest_callback.t
new file mode 100644
index 0000000000..ae4231b629
--- /dev/null
+++ b/cpan/Test-Simple/t/Test2/behavior/Subtest_callback.t
@@ -0,0 +1,48 @@
+use strict;
+use warnings;
+
+use Test2::Tools::Tiny;
+
+use Test2::API qw/run_subtest intercept/;
+
+my $step = 0;
+my @callback_calls = ();
+Test2::API::test2_add_callback_pre_subtest(
+    sub {
+        is(
+            $step,
+            0,
+            'pre-subtest callbacks should be invoked before the subtest',
+        );
+        ++$step;
+        push @callback_calls, [@_];
+    },
+);
+
+run_subtest(
+    (my $subtest_name='some subtest'),
+    (my $subtest_code=sub {
+         is(
+             $step,
+             1,
+             'subtest should be run after the pre-subtest callbacks',
+         );
+         ++$step;
+     }),
+    undef,
+    (my @subtest_args = (1,2,3)),
+);
+
+is_deeply(
+    \@callback_calls,
+    [[$subtest_name,$subtest_code,@subtest_args]],
+    'pre-subtest callbacks should be invoked with the expected arguments',
+);
+
+is(
+    $step,
+    2,
+    'the subtest should be run',
+);
+
+done_testing;
diff --git a/cpan/Test-Simple/t/Test2/modules/API.t b/cpan/Test-Simple/t/Test2/modules/API.t
index b709909720..d7a895377d 100644
--- a/cpan/Test-Simple/t/Test2/modules/API.t
+++ b/cpan/Test-Simple/t/Test2/modules/API.t
@@ -148,6 +148,12 @@ ok($CLASS->can('test2_no_wait')->(), "no_wait is set");
 $CLASS->can('test2_no_wait')->(undef);
 ok(!$CLASS->can('test2_no_wait')->(), "no_wait is not set");
 
+ok($CLASS->can('test2_ipc_wait_enabled')->(), "IPC waiting enabled");
+$CLASS->can('test2_ipc_wait_disable')->();
+ok(!$CLASS->can('test2_ipc_wait_enabled')->(), "IPC waiting disabled");
+$CLASS->can('test2_ipc_wait_enable')->();
+ok($CLASS->can('test2_ipc_wait_enabled')->(), "IPC waiting enabled");
+
 my $pctx;
 sub tool_a($;$) {
     Test2::API::context_do {
diff --git a/cpan/Test-Simple/t/Test2/modules/API/Instance.t b/cpan/Test-Simple/t/Test2/modules/API/Instance.t
index 10ba6ebad1..8e7e9a8a3b 100644
--- a/cpan/Test-Simple/t/Test2/modules/API/Instance.t
+++ b/cpan/Test-Simple/t/Test2/modules/API/Instance.t
@@ -36,6 +36,7 @@ is_deeply(
         context_acquire_callbacks => [],
         context_init_callbacks    => [],
         context_release_callbacks => [],
+        pre_subtest_callbacks     => [],
 
         stack => [],
     },
@@ -69,6 +70,7 @@ is_deeply(
         context_acquire_callbacks => [],
         context_init_callbacks    => [],
         context_release_callbacks => [],
+        pre_subtest_callbacks     => [],
 
         stack => [],
     },
@@ -154,6 +156,18 @@ like(
     "Exit callbacks must be coderefs"
 );
 
+$one->reset;
+$one->add_pre_subtest_callback($callback);
+is(@{$one->pre_subtest_callbacks}, 1, "added a pre-subtest callback");
+$one->add_pre_subtest_callback($callback);
+is(@{$one->pre_subtest_callbacks}, 2, "added another pre-subtest callback");
+
+like(
+    exception { $one->add_pre_subtest_callback({}) },
+    qr/Pre-subtest callbacks must be coderefs/,
+    "Pre-subtest callbacks must be coderefs"
+);
+
 if (CAN_REALLY_FORK) {
     $one->reset;
     my $pid = fork;
@@ -170,7 +184,18 @@ if (CAN_REALLY_FORK) {
         local $SIG{__WARN__} = sub { push @warnings => @_ };
         is(Test2::API::Instance::_ipc_wait, 255, "Process exited badly");
     }
-    like($warnings[0], qr/Process .* did not exit cleanly \(status: 255\)/, "Warn about exit");
+    like($warnings[0], qr/Process .* did not exit cleanly \(wstat: \S+, exit: 255, sig: 0\)/, "Warn about exit");
+
+    $pid = fork;
+    die "Failed to fork!" unless defined $pid;
+    unless($pid) { sleep 20; exit 0 }
+    kill('TERM', $pid) or die "Failed to send signal";
+    @warnings = ();
+    {
+        local $SIG{__WARN__} = sub { push @warnings => @_ };
+        is(Test2::API::Instance::_ipc_wait, 255, "Process exited badly");
+    }
+    like($warnings[0], qr/Process .* did not exit cleanly \(wstat: \S+, exit: 0, sig: 15\)/, "Warn about exit");
 }
 
 if (CAN_THREAD && $] ge '5.010') {
diff --git a/cpan/Test-Simple/t/Test2/modules/IPC.t b/cpan/Test-Simple/t/Test2/modules/IPC.t
index ddd49c0d9e..38be3b8f10 100644
--- a/cpan/Test-Simple/t/Test2/modules/IPC.t
+++ b/cpan/Test-Simple/t/Test2/modules/IPC.t
@@ -2,7 +2,7 @@ use strict;
 use warnings;
 
 use Test2::IPC qw/cull/;
-use Test2::API qw/context test2_ipc_drivers test2_ipc/;
+use Test2::API qw/context test2_ipc_drivers test2_ipc intercept/;
 
 use Test2::Tools::Tiny;
 
@@ -16,4 +16,6 @@ is_deeply(
 
 ok(__PACKAGE__->can('cull'), "Imported cull");
 
+ok(eval { intercept { Test2::IPC->import }; 1 }, "Can re-import Test2::IPC without error") or diag $@;
+
 done_testing;
diff --git a/cpan/Test-Simple/t/Test2/modules/IPC/Driver.t b/cpan/Test-Simple/t/Test2/modules/IPC/Driver.t
index 0f013286bc..d5ebbd5fd2 100644
--- a/cpan/Test-Simple/t/Test2/modules/IPC/Driver.t
+++ b/cpan/Test-Simple/t/Test2/modules/IPC/Driver.t
@@ -40,7 +40,7 @@ tests abort => sub {
     }
 
     is($err, "IPC Fatal Error: foo\n", "Got error");
-    is($out, "not ok - IPC Fatal Error\n", "got 'not ok' on stdout");
+    is($out, "Bail out! IPC Fatal Error: foo\n", "got 'bail-out' on stdout");
 
     ($err, $out) = ("", "");
 
@@ -52,7 +52,7 @@ tests abort => sub {
         $one->abort_trace('foo');
     }
 
-    is($out, "not ok - IPC Fatal Error\n", "got 'not ok' on stdout");
+    like($out, qr/Bail out! IPC Fatal Error: foo/, "got 'bail-out' on stdout");
     like($err, qr/IPC Fatal Error: foo/, "Got error");
 };
 }
diff --git a/cpan/Test-Simple/t/Test2/modules/IPC/Driver/Files.t b/cpan/Test-Simple/t/Test2/modules/IPC/Driver/Files.t
index 9ca1f5c84e..8626b1fb65 100644
--- a/cpan/Test-Simple/t/Test2/modules/IPC/Driver/Files.t
+++ b/cpan/Test-Simple/t/Test2/modules/IPC/Driver/Files.t
@@ -130,10 +130,12 @@ ok(!-d $tmpdir, "cleaned up temp dir");
 }
 
 {
-    no warnings 'once';
+    no warnings qw/once redefine/;
+    local *Test2::IPC::Driver::Files::driver_abort = sub {};
     local *Test2::IPC::Driver::Files::abort = sub {
         my $self = shift;
         local $self->{no_fatal} = 1;
+        local $self->{no_bail} = 1;
         $self->Test2::IPC::Driver::abort(@_);
         die 255;
     };
@@ -175,8 +177,6 @@ ok(!-d $tmpdir, "cleaned up temp dir");
     };
     $cleanup->();
 
-    is($out->{STDOUT}, "not ok - IPC Fatal Error\nnot ok - IPC Fatal Error\n", "printed ");
-
     like($out->{STDERR}, qr/IPC Temp Dir: \Q$tmpdir\E/m, "Got temp dir path");
     like($out->{STDERR}, qr/^# Not removing temp dir: \Q$tmpdir\E$/m, "Notice about not closing tempdir");
 
@@ -365,6 +365,7 @@ ok(!-d $tmpdir, "cleaned up temp dir");
             pid      => "123",
             tid      => "456",
             eid      => "789",
+            file     => join ipc_separator, qw'GLOBAL 123 456 789 Event Type Foo',
         },
         "Parsed global complete"
     );
@@ -380,6 +381,7 @@ ok(!-d $tmpdir, "cleaned up temp dir");
             pid      => "123",
             tid      => "456",
             eid      => "789",
+            file     => join ipc_separator, qw'GLOBAL 123 456 789 Event Type Foo',
         },
         "Parsed global ready"
     );
@@ -395,6 +397,7 @@ ok(!-d $tmpdir, "cleaned up temp dir");
             pid      => "123",
             tid      => "456",
             eid      => "789",
+            file     => join ipc_separator, qw'GLOBAL 123 456 789 Event Type Foo',
         },
         "Parsed global not ready"
     );
@@ -410,6 +413,7 @@ ok(!-d $tmpdir, "cleaned up temp dir");
             pid      => "123",
             tid      => "456",
             eid      => "789",
+            file     => join ipc_separator, qw'1 1 1 123 456 789 Event Type Foo',
         },
         "Parsed event complete"
     );
@@ -425,6 +429,7 @@ ok(!-d $tmpdir, "cleaned up temp dir");
             pid      => "123",
             tid      => "456",
             eid      => "789",
+            file     => join ipc_separator, qw'1 2 3 123 456 789 Event Type Foo',
         },
         "Parsed event ready"
     );
@@ -440,6 +445,7 @@ ok(!-d $tmpdir, "cleaned up temp dir");
             pid      => "123",
             tid      => "456",
             eid      => "789",
+            file     => join ipc_separator, qw'3 2 11 123 456 789 Event',
         },
         "Parsed event not ready"
     );
diff --git a/cpan/Test-Simple/t/Test2/regression/ipc_files_abort_exit.t b/cpan/Test-Simple/t/Test2/regression/ipc_files_abort_exit.t
index 772d12acbc..b425443e00 100644
--- a/cpan/Test-Simple/t/Test2/regression/ipc_files_abort_exit.t
+++ b/cpan/Test-Simple/t/Test2/regression/ipc_files_abort_exit.t
@@ -1,63 +1,67 @@
 use strict;
 use warnings;
-use Test2::IPC;
 use Test2::Tools::Tiny;
-use Test2::API qw/context test2_stack/;
 use Test2::Util qw/CAN_FORK/;
 
 BEGIN {
+    skip_all "Set AUTHOR_TESTING to run this test" unless $ENV{AUTHOR_TESTING};
     skip_all "System cannot fork" unless CAN_FORK;
     skip_all "known to fail on $]" if $] le "5.006002";
 }
 
-plan(3);
+use IPC::Open3 qw/open3/;
+use File::Temp qw/tempdir/;
 
-pipe(my ($read, $write));
+my $tempdir = tempdir(CLEANUP => 1);
 
-test2_stack()->top;
-my $hub = test2_stack()->new_hub();
+open(my $stdout, '>', "$tempdir/stdout") or die "Could not open: $!";
+open(my $stderr, '>', "$tempdir/stderr") or die "Could not open: $!";
 
-my $pid = fork();
-die "Failed to fork" unless defined $pid;
+my $pid = open3(undef, ">&" . fileno($stdout), ">&" . fileno($stderr), $^X, '-Ilib', '-e', <<'EOT');
+use Test2::IPC::Driver::Files;
+use Test2::IPC;
+use Test2::Tools::Tiny;
+use Test2::API qw/test2_ipc/;
+plan 1;
+ok(1);
 
-if ($pid) {
-    close($read);
-    test2_stack()->pop($hub);
-    $hub = undef;
-    print $write "Go\n";
-    close($write);
-    waitpid($pid, 0);
-    my $err = $? >> 8;
-    is($err, 255, "Exit code was not masked");
-    ok($err != 100, "Did not hit the safety exit");
-}
-else {
-    close($write);
-    my $ignore = <$read>;
-    close($read);
-    close(STDERR);
-    close(STDOUT);
-    open(STDERR, '>', my $x);
-    my $ctx = context(hub => $hub, level => -1);
-    my $clone = $ctx->snapshot;
-    $ctx->release;
-    $clone->ok(0, "Should not see this");
-    print STDERR "\n\nSomething went wrong!!!!\n\n";
-    exit 100; # Safety exit
-};
-
-
-# The rest of this is to make sure nothing that happens when reading the event
-# messes with $?.
-
-pipe($read, $write);
-
-$pid = fork;
-die "Failed to fork" unless defined $pid;
-
-unless($pid) {
-    my $ignore = <$read>;
-    ok(1, "Test in forked process");
+my $tmpdir = test2_ipc()->tempdir;
+open(my $fh, '>', "$tmpdir/leftover") or die "Could not open file: $!";
+print $fh "XXX\n";
+close($fh) or die "Could not clone file";
+
+print "TEMPDIR: $tmpdir\n";
+
+exit 100;
+
+EOT
+
+waitpid($pid, 0);
+my $exit = $?;
+
+open($stdout, '<', "$tempdir/stdout") or die "Could not open: $!";
+open($stderr, '<', "$tempdir/stderr") or die "Could not open: $!";
+
+$stdout = join "" => <$stdout>;
+$stderr = join "" => <$stderr>;
+
+is(($exit >> 8), 255, "exited 255");
+like($stderr, qr{^IPC Fatal Error: Leftover files in the directory \(.*/leftover\)!$}m, "Got expected error");
+like($stdout, qr{^Bail out! IPC Fatal Error: Leftover files in the directory \(.*leftover\)!$}m, "Got a bail printed");
+
+if(ok($stdout =~ m/^TEMPDIR: (.*)$/m, "Found temp dir")) {
+    chomp(my $tmpdir = $1);
+    if (-d $tmpdir) {
+        note "Cleaning up temp dir\n";
+
+        opendir(my $dh, $tmpdir) or diag "Could not open temp dir: $!";
+        for my $file (readdir($dh)) {
+            next if $file =~ m/^\./;
+            unlink("$tmpdir/$file") or diag "Could not remove $tmpdir/$file: $!";
+        }
+        closedir($dh);
+        rmdir($tmpdir) or diag "Could not remove temp dir: $!";
+    }
 }
 
-print $write "Go\n";
+done_testing;