In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/17fddc5cffca4f968d3565ff012c0cfb3af40d68?hp=30b05491367d1fecbb231575d1112420d410cafb>
- Log ----------------------------------------------------------------- commit 17fddc5cffca4f968d3565ff012c0cfb3af40d68 Author: Rafael Garcia-Suarez <[email protected]> Date: Thu Apr 15 16:46:40 2010 +0200 Bump $VERSION of IPC::Open3 to 1.06 M ext/IPC-Open3/lib/IPC/Open3.pm commit 8960aa876f446ad29b892204eeb41fc724123dcb Author: Eric Brine <[email protected]> Date: Mon Jan 18 10:21:20 2010 -0800 open3 errors in child croak parent RT#72016 Errors in open3 no longer appear to originate from the executed command on forking systems. M ext/IPC-Open3/lib/IPC/Open3.pm M ext/IPC-Open3/t/IPC-Open3.t commit bb5bc4969d327481d130990eb06757413584aa24 Author: Eric Brine <[email protected]> Date: Sun Jan 17 20:44:14 2010 -0800 Add TODO test for RT#72016 M ext/IPC-Open3/t/IPC-Open3.t ----------------------------------------------------------------------- Summary of changes: ext/IPC-Open3/lib/IPC/Open3.pm | 147 ++++++++++++++++++++++++++-------------- ext/IPC-Open3/t/IPC-Open3.t | 19 +++++- 2 files changed, 115 insertions(+), 51 deletions(-) diff --git a/ext/IPC-Open3/lib/IPC/Open3.pm b/ext/IPC-Open3/lib/IPC/Open3.pm index 82c20ae..50ae61e 100644 --- a/ext/IPC-Open3/lib/IPC/Open3.pm +++ b/ext/IPC-Open3/lib/IPC/Open3.pm @@ -9,7 +9,7 @@ require Exporter; use Carp; use Symbol qw(gensym qualify); -$VERSION = 1.05; +$VERSION = 1.06; @ISA = qw(Exporter); @EXPORT = qw(open3); @@ -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 79d5ced..23ca8e5 100644 --- a/ext/IPC-Open3/t/IPC-Open3.t +++ b/ext/IPC-Open3/t/IPC-Open3.t @@ -47,7 +47,7 @@ my ($pid, $reaped_pid); STDOUT->autoflush; STDERR->autoflush; -print "1..22\n"; +print "1..23\n"; # basic ok 1, $pid = open3 'WRITE', 'READ', 'ERROR', $perl, '-e', cmd_line(<<'EOF'); @@ -146,3 +146,20 @@ else { print WRITE "ok 22\n"; waitpid $pid, 0; } + +# RT 72016 +eval{$pid = open3 'WRITE', 'READ', 'ERROR', '/non/existant/program'; }; +if (IPC::Open3::DO_SPAWN) { + if ($@ || waitpid($pid, 0) > 0) { + print "ok 23\n"; + } else { + print "not ok 23\n"; + } +} else { + if ($@) { + print "ok 23\n"; + } else { + waitpid($pid, 0); + print "not ok 23\n"; + } +} -- Perl5 Master Repository
