71 lines
2.5 KiB
Diff
71 lines
2.5 KiB
Diff
From 35608a1658fe75c79ca53d96aea6cf7cb2a98615 Mon Sep 17 00:00:00 2001
|
|
From: Tony Cook <tony@develop-help.com>
|
|
Date: Thu, 9 May 2019 09:52:30 +1000
|
|
Subject: [PATCH] (perl #122112) a simpler fix for pclose() aborted by a signal
|
|
MIME-Version: 1.0
|
|
Content-Type: text/plain; charset=UTF-8
|
|
Content-Transfer-Encoding: 8bit
|
|
|
|
This change results in a zombie child process for the lifetime of
|
|
the process, but I think that's the responsibility of the signal
|
|
handler that aborted pclose().
|
|
|
|
We could add some magic to retry (and retry and retry) waiting on
|
|
child process as we rewind (since there's no other way to remove
|
|
the zombie), but the program has chosen implicitly to abort the
|
|
wait() done by pclose() and it's best to honor that.
|
|
|
|
If we do choose to retry the wait() we might be blocking an attempt
|
|
by the process to terminate, whether by exit() or die().
|
|
|
|
If a program does need more flexible handling there's always
|
|
pipe()/fork()/exec() and/or the various event-driven frameworks on
|
|
CPAN.
|
|
|
|
Signed-off-by: Petr Písař <ppisar@redhat.com>
|
|
---
|
|
doio.c | 12 +++++++++++-
|
|
t/io/pipe.t | 2 --
|
|
2 files changed, 11 insertions(+), 3 deletions(-)
|
|
|
|
diff --git a/doio.c b/doio.c
|
|
index 0cc4e55404..05a06968dc 100644
|
|
--- a/doio.c
|
|
+++ b/doio.c
|
|
@@ -1779,7 +1779,17 @@ Perl_io_close(pTHX_ IO *io, GV *gv, bool not_implicit, bool warn_on_fail)
|
|
|
|
if (IoIFP(io)) {
|
|
if (IoTYPE(io) == IoTYPE_PIPE) {
|
|
- const int status = PerlProc_pclose(IoIFP(io));
|
|
+ PerlIO *fh = IoIFP(io);
|
|
+ int status;
|
|
+
|
|
+ /* my_pclose() can propagate signals which might bypass any code
|
|
+ after the call here if the signal handler throws an exception.
|
|
+ This would leave the handle in the IO object and try to close it again
|
|
+ when the SV is destroyed on unwind or global destruction.
|
|
+ So NULL it early.
|
|
+ */
|
|
+ IoOFP(io) = IoIFP(io) = NULL;
|
|
+ status = PerlProc_pclose(fh);
|
|
if (not_implicit) {
|
|
STATUS_NATIVE_CHILD_SET(status);
|
|
retval = (STATUS_UNIX == 0);
|
|
diff --git a/t/io/pipe.t b/t/io/pipe.t
|
|
index 1d01db6af6..fc3071300d 100644
|
|
--- a/t/io/pipe.t
|
|
+++ b/t/io/pipe.t
|
|
@@ -255,9 +255,7 @@ close \$fh;
|
|
PROG
|
|
print $prog;
|
|
my $out = fresh_perl($prog, {});
|
|
- $::TODO = "not fixed yet";
|
|
cmp_ok($out, '!~', qr/refcnt/, "no exception from PerlIO");
|
|
- undef $::TODO;
|
|
# checks that that program did something rather than failing to
|
|
# compile
|
|
cmp_ok($out, '=~', qr/Died at/, "but we did get the exception from die");
|
|
--
|
|
2.20.1
|
|
|