open3 errors in child croak parent RT#72016

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

diff --git a/ext/IPC-Open3/lib/IPC/Open3.pm b/ext/IPC-Open3/lib/IPC/Open3.pm
index 82c20ae..c367758 100644 (file)
--- 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 849b0ba..23ca8e5 100644 (file)
--- 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";
     }
 }