From e9d373c4fc63458e812eaac6aef324f1b45fd607 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 17 Oct 2013 15:29:58 +1100
Subject: [PATCH] [perl #119893] avoid waiting on pid 0

When a filehandle is cloned into a standard handle, do_openn() copies
the pid from the original handle in PL_fdpid to the standard handle
and zeroes the entry for the original handle, so when the original
handle was closed Perl_my_pclose() would call wait4pid() with a pid of 0.

With v5.19.3-614-gd4c0274 I modified wait4pid(), perl's waitpid/wait4()
wrapper, to allow a pid of zero through to the actual system call when
available.

These combined so that following v5.19.3-614-gd4c0274 in some
circumstances closing the original handle would block by calling
waitpid(0, ...) or wait4(0, ...), which waits for any child process in
the same process group to terminate.

This commit changes Perl_my_pclose() to wait for the child only when
the stored pid is positive.
---
 MANIFEST        |  1 +
 t/io/closepid.t | 47 +++++++++++++++++++++++++++++++++++++++++++++++
 util.c          | 14 ++++++++------
 3 files changed, 56 insertions(+), 6 deletions(-)
 create mode 100644 t/io/closepid.t

diff --git a/MANIFEST b/MANIFEST
index 5501d78..47e0c1d 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4993,6 +4993,7 @@ time64.h			64 bit clean time.h (header)
 t/io/argv.t			See if ARGV stuff works
 t/io/binmode.t			See if binmode() works
 t/io/bom.t			See if scripts can start with a byte order mark
+t/io/closepid.t			See if close works for subprocesses
 t/io/crlf.t			See if :crlf works
 t/io/crlf_through.t		See if pipe passes data intact with :crlf
 t/io/data.t			See if DATA works
diff --git a/t/io/closepid.t b/t/io/closepid.t
new file mode 100644
index 0000000..aa937f5
--- /dev/null
+++ b/t/io/closepid.t
@@ -0,0 +1,47 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require './test.pl';
+}
+
+if ($^O eq 'dos') {
+    skip_all("no multitasking");
+}
+
+plan tests => 3;
+watchdog(10, $^O eq 'MSWin32' ? "alarm" : '');
+
+use Config;
+$| = 1;
+$SIG{PIPE} = 'IGNORE';
+$SIG{HUP} = 'IGNORE' if $^O eq 'interix';
+
+my $perl = which_perl();
+$perl .= qq[ "-I../lib"];
+
+my $killsig = 'HUP';
+$killsig = 1 unless $Config{sig_name} =~ /\bHUP\b/;
+
+SKIP:
+{
+    skip("Not relevant to $^O", 3)
+      if $^O eq "MSWin32" || $^O eq "VMS";
+    skip("only matters for waitpid or wait4", 3)
+      unless $Config{d_waitpid} || $Config{d_wait4};
+    # [perl #119893]
+    # close on the original of a popen handle dupped to a standard handle
+    # would wait4pid(0, ...)
+    open my $savein, "<&", \*STDIN;
+    my $pid = open my $fh1, qq/$perl -e "sleep 50" |/;
+    ok($pid, "open a pipe");
+    # at this point PL_fdpids[fileno($fh1)] is the pid of the new process
+    ok(open(STDIN, "<&=", $fh1), "dup the pipe");
+    # now PL_fdpids[fileno($fh1)] is zero and PL_fdpids[0] is
+    # the pid of the process created above, previously this would block
+    # internally on waitpid(0, ...)
+    ok(close($fh1), "close the original");
+    kill $killsig, $pid;
+    open STDIN, "<&", $savein;
+}
diff --git a/util.c b/util.c
index f020b4b..b62caf8 100644
--- a/util.c
+++ b/util.c
@@ -2706,19 +2706,21 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     bool close_failed;
     dSAVEDERRNO;
     const int fd = PerlIO_fileno(ptr);
+    bool should_wait;
+
+    svp = av_fetch(PL_fdpid,fd,TRUE);
+    pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
+    SvREFCNT_dec(*svp);
+    *svp = NULL;
 
 #ifdef USE_PERLIO
     /* Find out whether the refcount is low enough for us to wait for the
        child proc without blocking. */
-    const bool should_wait = PerlIOUnix_refcnt(fd) == 1;
+    should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
 #else
-    const bool should_wait = 1;
+    should_wait = pid > 0;
 #endif
 
-    svp = av_fetch(PL_fdpid,fd,TRUE);
-    pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
-    SvREFCNT_dec(*svp);
-    *svp = NULL;
 #ifdef OS2
     if (pid == -1) {			/* Opened by popen. */
 	return my_syspclose(ptr);
-- 
2.7.4