In perl.git, the branch blead has been updated <https://perl5.git.perl.org/perl.git/commitdiff/35608a1658fe75c79ca53d96aea6cf7cb2a98615?hp=c6dcb9ed461718e37907fd4a12e9c4e267d460eb>
- Log ----------------------------------------------------------------- commit 35608a1658fe75c79ca53d96aea6cf7cb2a98615 Author: Tony Cook <[email protected]> Date: Thu May 9 09:52:30 2019 +1000 (perl #122112) a simpler fix for pclose() aborted by a signal 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. commit fb5e77103dd443cc2112ba14dc665aa5ec072ce6 Author: Tony Cook <[email protected]> Date: Wed May 30 14:03:04 2018 +1000 (perl #122112) test for signal handler death in pclose ----------------------------------------------------------------------- Summary of changes: doio.c | 12 +++++++++++- t/io/pipe.t | 21 ++++++++++++++++++++- 2 files changed, 31 insertions(+), 2 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 f9ee65afe8..fc3071300d 100644 --- a/t/io/pipe.t +++ b/t/io/pipe.t @@ -10,7 +10,7 @@ if (!$Config{'d_fork'}) { skip_all("fork required to pipe"); } else { - plan(tests => 25); + plan(tests => 27); } my $Perl = which_perl(); @@ -241,3 +241,22 @@ SKIP: { is($child, -1, 'child reaped if piped program cannot be executed'); } + +{ + # [perl #122112] refcnt: fd -1 < 0 when a signal handler dies + # while a pipe close is waiting on a child process + my $prog = <<PROG; +\$SIG{ALRM}=sub{die}; +alarm 1; +\$Perl = "$Perl"; +my \$cmd = qq(\$Perl -e "sleep 3"); +my \$pid = open my \$fh, "|\$cmd" or die "\$!\n"; +close \$fh; +PROG + print $prog; + my $out = fresh_perl($prog, {}); + cmp_ok($out, '!~', qr/refcnt/, "no exception from PerlIO"); + # 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"); +} -- Perl5 Master Repository
