open3 errors in child croak parent RT#72016

Errors in open3 no longer appear to originate from the executed command on forking systems.

2 files changed, 99 insertions, 57 deletions

diff --git a/ext/IPC-Open3/lib/IPC/Open3.pm b/ext/IPC-Open3/lib/IPC/Open3.pm
index 82c20ae828..c367758168 100644
--- a/ext/IPC-Open3/lib/IPC/Open3.pm
+++ b/ext/IPC-Open3/lib/IPC/Open3.pm
@@ -48,7 +48,7 @@ instead of a pipe(2) made.
 
 If either reader or writer is the null string, this will be replaced
 by an autogenerated filehandle.  If so, you must pass a valid lvalue
-in the parameter slot so it can be overwritten in the caller, or 
+in the parameter slot so it can be overwritten in the caller, or
 an exception will be raised.
 
 The filehandles may also be integers, in which case they are understood
@@ -68,9 +68,9 @@ C<open(FOO, "-|")> the child process will just be the forked Perl
 process rather than an external command.  This feature isn't yet
 supported on Win32 platforms.
 
-open3() does not wait for and reap the child process after it exits.  
+open3() does not wait for and reap the child process after it exits.
 Except for short programs where it's acceptable to let the operating system
-take care of this, you need to do this yourself.  This is normally as 
+take care of this, you need to do this yourself.  This is normally as
 simple as calling C<waitpid $pid, 0> when you're done with the process.
 Failing to do this can result in an accumulation of defunct or "zombie"
 processes.  See L<perlfunc/waitpid> for more information.
@@ -161,6 +161,18 @@ sub xpipe {
     pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!";
 }
 
+sub xpipe_anon {
+    pipe $_[0], $_[1] or croak "$Me: pipe failed: $!";
+}
+
+sub xclose_on_exec {
+    require Fcntl;
+    my $flags = fcntl($_[0], &Fcntl::F_GETFD, 0)
+	or croak "$Me: fcntl failed: $!";
+    fcntl($_[0], &Fcntl::F_SETFD, $flags|&Fcntl::FD_CLOEXEC)
+	or croak "$Me: fcntl failed: $!";
+}
+
 # I tried using a * prototype character for the filehandle but it still
 # disallows a bearword while compiling under strict subs.
 
@@ -199,12 +211,12 @@ sub _open3 {
     unless (eval  {
 	$dad_wtr = $_[1] = gensym unless defined $dad_wtr && length $dad_wtr;
 	$dad_rdr = $_[2] = gensym unless defined $dad_rdr && length $dad_rdr;
-	1; }) 
+	1; })
     {
 	# must strip crud for croak to add back, or looks ugly
 	$@ =~ s/(?<=value attempted) at .*//s;
 	croak "$Me: $@";
-    } 
+    }
 
     $dad_err ||= $dad_rdr;
 
@@ -225,54 +237,89 @@ sub _open3 {
     xpipe $dad_rdr, $kid_wtr if !$dup_rdr;
     xpipe $dad_err, $kid_err if !$dup_err && $dad_err ne $dad_rdr;
 
-    $kidpid = DO_SPAWN ? -1 : xfork;
-    if ($kidpid == 0) {		# Kid
-	# A tie in the parent should not be allowed to cause problems.
-	untie *STDIN;
-	untie *STDOUT;
-	# If she wants to dup the kid's stderr onto her stdout I need to
-	# save a copy of her stdout before I put something else there.
-	if ($dad_rdr ne $dad_err && $dup_err
-		&& xfileno($dad_err) == fileno(STDOUT)) {
-	    my $tmp = gensym;
-	    xopen($tmp, ">&$dad_err");
-	    $dad_err = $tmp;
-	}
+    if (!DO_SPAWN) {
+	# Used to communicate exec failures.
+	xpipe my $stat_r, my $stat_w;
+
+	$kidpid = xfork;
+	if ($kidpid == 0) {  # Kid
+	    eval {
+		# A tie in the parent should not be allowed to cause problems.
+		untie *STDIN;
+		untie *STDOUT;
+
+		close $stat_r;
+		xclose_on_exec $stat_w;
+
+		# If she wants to dup the kid's stderr onto her stdout I need to
+		# save a copy of her stdout before I put something else there.
+		if ($dad_rdr ne $dad_err && $dup_err
+			&& xfileno($dad_err) == fileno(STDOUT)) {
+		    my $tmp = gensym;
+		    xopen($tmp, ">&$dad_err");
+		    $dad_err = $tmp;
+		}
+
+		if ($dup_wtr) {
+		    xopen \*STDIN,  "<&$dad_wtr" if fileno(STDIN) != xfileno($dad_wtr);
+		} else {
+		    xclose $dad_wtr;
+		    xopen \*STDIN,  "<&=" . fileno $kid_rdr;
+		}
+		if ($dup_rdr) {
+		    xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != xfileno($dad_rdr);
+		} else {
+		    xclose $dad_rdr;
+		    xopen \*STDOUT, ">&=" . fileno $kid_wtr;
+		}
+		if ($dad_rdr ne $dad_err) {
+		    if ($dup_err) {
+			# I have to use a fileno here because in this one case
+			# I'm doing a dup but the filehandle might be a reference
+			# (from the special case above).
+			xopen \*STDERR, ">&" . xfileno($dad_err)
+			    if fileno(STDERR) != xfileno($dad_err);
+		    } else {
+			xclose $dad_err;
+			xopen \*STDERR, ">&=" . fileno $kid_err;
+		    }
+		} else {
+		    xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT);
+		}
+		return 0 if ($cmd[0] eq '-');
+		exec @cmd or do {
+		    local($")=(" ");
+		    croak "$Me: exec of @cmd failed";
+		};
+	    };
+
+	    my $bang = 0+$!;
+	    my $err = $@;
+	    utf8::encode $err if $] >= 5.008;
+	    print $stat_w pack('IIa*', $bang, length($err), $err);
+	    close $stat_w;
 
-	if ($dup_wtr) {
-	    xopen \*STDIN,  "<&$dad_wtr" if fileno(STDIN) != xfileno($dad_wtr);
-	} else {
-	    xclose $dad_wtr;
-	    xopen \*STDIN,  "<&=" . fileno $kid_rdr;
-	}
-	if ($dup_rdr) {
-	    xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != xfileno($dad_rdr);
-	} else {
-	    xclose $dad_rdr;
-	    xopen \*STDOUT, ">&=" . fileno $kid_wtr;
+	    eval { require POSIX; POSIX::_exit(255); };
+	    exit 255;
 	}
-	if ($dad_rdr ne $dad_err) {
-	    if ($dup_err) {
-		# I have to use a fileno here because in this one case
-		# I'm doing a dup but the filehandle might be a reference
-		# (from the special case above).
-		xopen \*STDERR, ">&" . xfileno($dad_err)
-		    if fileno(STDERR) != xfileno($dad_err);
-	    } else {
-		xclose $dad_err;
-		xopen \*STDERR, ">&=" . fileno $kid_err;
+	else {  # Parent
+	    close $stat_w;
+	    my $to_read = length(pack('I', 0)) * 2;
+	    my $bytes_read = read($stat_r, my $buf = '', $to_read);
+	    if ($bytes_read) {
+		(my $bang, $to_read) = unpack('II', $buf);
+		read($stat_r, my $err = '', $to_read);
+		if ($err) {
+		    utf8::decode $err if $] >= 5.008;
+		} else {
+		    $err = "$Me: " . ($! = $bang);
+		}
+		$! = $bang;
+		die($err);
 	    }
-	} else {
-	    xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT);
 	}
-	return 0 if ($cmd[0] eq '-');
-	local($")=(" ");
-	exec @cmd or do {
-	    carp "$Me: exec of @cmd failed";
-	    eval { require POSIX; POSIX::_exit(255); };
-	    exit 255;
-	};
-    } elsif (DO_SPAWN) {
+    }
+    else {  # DO_SPAWN
 	# All the bookkeeping of coincidence between handles is
 	# handled in spawn_with_handles.
 
diff --git a/ext/IPC-Open3/t/IPC-Open3.t b/ext/IPC-Open3/t/IPC-Open3.t
index 849b0baa2e..23ca8e5602 100644
--- a/ext/IPC-Open3/t/IPC-Open3.t
+++ b/ext/IPC-Open3/t/IPC-Open3.t
@@ -157,14 +157,9 @@ if (IPC::Open3::DO_SPAWN) {
     }
 } else {
     if ($@) {
-	# exec failure should throw exception in parent.
-	print "ok 23 # TODO RT 72016\n";
+	print "ok 23\n";
     } else {
-	if (waitpid($pid, 0) > 0) {
-	    # exec failure currently appears as child error.
-	    print "not ok 23 # TODO RT 72016\n";
-	} else {
-	    print "not ok 23\n";
-	}
+	waitpid($pid, 0);
+	print "not ok 23\n";
     }
 }