X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/b74a613e3e588946368dbb832eaeb7328c147bdc..62c7b79a597b00fcdcb4a3aef52951b8b4fc9824:/ext/IPC-Open3/lib/IPC/Open3.pm diff --git a/ext/IPC-Open3/lib/IPC/Open3.pm b/ext/IPC-Open3/lib/IPC/Open3.pm index d257c41..c8620b7 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.11'; +$VERSION = '1.16'; @ISA = qw(Exporter); @EXPORT = qw(open3); @@ -57,7 +57,8 @@ as file descriptors. open3() returns the process ID of the child process. It doesn't return on failure: it just raises an exception matching C. However, C failures in the child (such as no such file or permission denied), -are just reported to CHLD_ERR, as it is not possible to trap them. +are just reported to CHLD_ERR under Windows and OS/2, as it is not possible +to trap them. If the child process dies for any reason, the next write to CHLD_IN is likely to generate a SIGPIPE in the parent, which is fatal by default. @@ -98,7 +99,7 @@ C and continually read and write a line from it. =item L -Like Open3 but without STDERR catpure. +Like Open3 but without STDERR capture. =item L @@ -149,28 +150,10 @@ our $Me = 'open3 (bug)'; # you should never see this, it's always localized # Fatal.pm needs to be fixed WRT prototypes. -sub xfork { - my $pid = fork; - defined $pid or croak "$Me: fork failed: $!"; - return $pid; -} - 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 bareword while compiling under strict subs. @@ -181,14 +164,12 @@ sub xopen { } sub xclose { - $_[0] =~ /\A=?(\d+)\z/ ? eval { require POSIX; POSIX::close($1); } : close $_[0] + $_[0] =~ /\A=?(\d+)\z/ + ? do { my $fh; open($fh, $_[1] . '&=' . $1) and close($fh); } + : close $_[0] or croak "$Me: close($_[0]) failed: $!"; } -sub fh_is_fd { - return $_[0] =~ /\A=?(\d+)\z/; -} - sub xfileno { return $1 if $_[0] =~ /\A=?(\d+)\z/; # deal with fh just being an fd return fileno $_[0]; @@ -204,6 +185,10 @@ sub _open3 { # it's too ugly to use @_ throughout to make perl do it for us # tchrist 5-Mar-00 + # Historically, open3(undef...) has silently worked, so keep + # it working. + splice @_, 0, 1, undef if \$_[0] == \undef; + splice @_, 1, 1, undef if \$_[1] == \undef; unless (eval { $_[0] = gensym unless defined $_[0] && length $_[0]; $_[1] = gensym unless defined $_[1] && length $_[1]; @@ -214,42 +199,48 @@ sub _open3 { croak "$Me: $@"; } - my $kid_rdr = gensym; - my $kid_wtr = gensym; - my $kid_err = gensym; - - my @handles = ({ mode => 'r', open_as => \$kid_rdr, handle => \*STDIN }, - { mode => 'w', open_as => \$kid_wtr, handle => \*STDOUT }, - { mode => 'w', open_as => \$kid_err, handle => \*STDERR }, + my @handles = ({ mode => '<', handle => \*STDIN }, + { mode => '>', handle => \*STDOUT }, + { mode => '>', handle => \*STDERR }, ); - my($dad_wtr, $dad_rdr, $dad_err, @cmd) = @_; - my($dup_wtr, $dup_rdr, $dup_err, $kidpid); - if (@cmd > 1 and $cmd[0] eq '-') { + foreach (@handles) { + $_->{parent} = shift; + $_->{open_as} = gensym; + } + + if (@_ > 1 and $_[0] eq '-') { croak "Arguments don't make sense when the command is '-'" } - $dad_err ||= $dad_rdr; + $handles[2]{parent} ||= $handles[1]{parent}; + $handles[2]{dup_of_out} = $handles[1]{parent} eq $handles[2]{parent}; - $dup_wtr = ($dad_wtr =~ s/^[<>]&//); - $dup_rdr = ($dad_rdr =~ s/^[<>]&//); - $dup_err = ($dad_err =~ s/^[<>]&//); + my $package; + foreach (@handles) { + $_->{dup} = ($_->{parent} =~ s/^[<>]&//); - # force unqualified filehandles into caller's package - my $package = caller 1; - $dad_wtr = qualify $dad_wtr, $package unless fh_is_fd($dad_wtr); - $dad_rdr = qualify $dad_rdr, $package unless fh_is_fd($dad_rdr); - $dad_err = qualify $dad_err, $package unless fh_is_fd($dad_err); + if ($_->{parent} !~ /\A=?(\d+)\z/) { + # force unqualified filehandles into caller's package + $package //= caller 1; + $_->{parent} = qualify $_->{parent}, $package; + } - xpipe $kid_rdr, $dad_wtr if !$dup_wtr; - xpipe $dad_rdr, $kid_wtr if !$dup_rdr; - xpipe $dad_err, $kid_err if !$dup_err && $dad_err ne $dad_rdr; + next if $_->{dup} or $_->{dup_of_out}; + if ($_->{mode} eq '<') { + xpipe $_->{open_as}, $_->{parent}; + } else { + xpipe $_->{parent}, $_->{open_as}; + } + } + my $kidpid; if (!DO_SPAWN) { # Used to communicate exec failures. xpipe my $stat_r, my $stat_w; - $kidpid = xfork; + $kidpid = fork; + croak "$Me: fork failed: $!" unless defined $kidpid; if ($kidpid == 0) { # Kid eval { # A tie in the parent should not be allowed to cause problems. @@ -257,47 +248,43 @@ sub _open3 { untie *STDOUT; close $stat_r; - xclose_on_exec $stat_w; + require Fcntl; + my $flags = fcntl $stat_w, &Fcntl::F_GETFD, 0; + croak "$Me: fcntl failed: $!" unless $flags; + fcntl $stat_w, &Fcntl::F_SETFD, $flags|&Fcntl::FD_CLOEXEC + or croak "$Me: fcntl failed: $!"; # 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) { + if (!$handles[2]{dup_of_out} && $handles[2]{dup} + && xfileno($handles[2]{parent}) == fileno \*STDOUT) { my $tmp = gensym; - xopen($tmp, ">&$dad_err"); - $dad_err = $tmp; + xopen($tmp, '>&', $handles[2]{parent}); + $handles[2]{parent} = $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) { - xopen \*STDERR, '>&', $dad_err - if fileno \*STDERR != xfileno($dad_err); + foreach (@handles) { + if ($_->{dup_of_out}) { + xopen \*STDERR, ">&STDOUT" + if defined fileno STDERR && fileno STDERR != fileno STDOUT; + } elsif ($_->{dup}) { + xopen $_->{handle}, $_->{mode} . '&', $_->{parent} + if fileno $_->{handle} != xfileno($_->{parent}); } else { - xclose $dad_err; - xopen \*STDERR, ">&=" . fileno $kid_err; + xclose $_->{parent}, $_->{mode}; + xopen $_->{handle}, $_->{mode} . '&=', + fileno $_->{open_as}; } - } else { - xopen \*STDERR, ">&STDOUT" - if defined fileno \*STDERR && fileno \*STDERR != fileno \*STDOUT; } - return 0 if ($cmd[0] eq '-'); - exec @cmd or do { + return 1 if ($_[0] eq '-'); + exec @_ or do { local($")=(" "); - croak "$Me: exec of @cmd failed"; + croak "$Me: exec of @_ failed"; }; - }; + } and do { + close $stat_w; + return 0; + }; my $bang = 0+$!; my $err = $@; @@ -315,6 +302,7 @@ sub _open3 { if ($bytes_read) { (my $bang, $to_read) = unpack('II', $buf); read($stat_r, my $err = '', $to_read); + waitpid $kidpid, 0; # Reap child which should have exited if ($err) { utf8::decode $err if $] >= 5.008; } else { @@ -330,43 +318,35 @@ sub _open3 { # handled in spawn_with_handles. my @close; - if ($dup_wtr) { - $kid_rdr = $dad_wtr =~ /\A[0-9]+\z/ ? $dad_wtr : \*{$dad_wtr}; - push @close, $kid_rdr; - } else { - push @close, \*{$dad_wtr}, $kid_rdr; - } - if ($dup_rdr) { - $kid_wtr = $dad_rdr =~ /\A[0-9]+\z/ ? $dad_rdr : \*{$dad_rdr}; - push @close, $kid_wtr; - } else { - push @close, \*{$dad_rdr}, $kid_wtr; - } - if ($dad_rdr ne $dad_err) { - if ($dup_err) { - $kid_err = $dad_err =~ /\A[0-9]+\z/ ? $dad_err : \*{$dad_err}; - push @close, $kid_err; + + foreach (@handles) { + if ($_->{dup_of_out}) { + $_->{open_as} = $handles[1]{open_as}; + } elsif ($_->{dup}) { + $_->{open_as} = $_->{parent} =~ /\A[0-9]+\z/ + ? $_->{parent} : \*{$_->{parent}}; + push @close, $_->{open_as}; } else { - push @close, \*{$dad_err}, $kid_err; + push @close, \*{$_->{parent}}, $_->{open_as}; } - } else { - $kid_err = $kid_wtr; } require IO::Pipe; $kidpid = eval { - spawn_with_handles(\@handles, \@close, @cmd); + spawn_with_handles(\@handles, \@close, @_); }; die "$Me: $@" if $@; } - xclose $kid_rdr if !$dup_wtr; - xclose $kid_wtr if !$dup_rdr; - xclose $kid_err if !$dup_err && $dad_rdr ne $dad_err; + foreach (@handles) { + next if $_->{dup} or $_->{dup_of_out}; + xclose $_->{open_as}, $_->{mode}; + } + # If the write handle is a dup give it away entirely, close my copy # of it. - xclose $dad_wtr if $dup_wtr; + xclose $handles[0]{parent}, $handles[0]{mode} if $handles[0]{dup}; - select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe + select((select($handles[0]{parent}), $| = 1)[0]); # unbuffer pipe $kidpid; } @@ -382,7 +362,6 @@ sub spawn_with_handles { my $fds = shift; # Fields: handle, mode, open_as my $close_in_child = shift; my ($fd, $pid, @saved_fh, $saved, %saved, @errs); - require Fcntl; foreach $fd (@$fds) { $fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode}); @@ -393,12 +372,13 @@ sub spawn_with_handles { unless eval { $fd->{handle}->isa('IO::Handle') } ; # If some of handles to redirect-to coincide with handles to # redirect, we need to use saved variants: - $fd->{handle}->fdopen(defined fileno ${$fd->{open_as}} - ? $saved{fileno ${$fd->{open_as}}} || ${$fd->{open_as}} - : ${$fd->{open_as}}, + $fd->{handle}->fdopen(defined fileno $fd->{open_as} + ? $saved{fileno $fd->{open_as}} || $fd->{open_as} + : $fd->{open_as}, $fd->{mode}); } unless ($^O eq 'MSWin32') { + require Fcntl; # Stderr may be redirected below, so we save the err text: foreach $fd (@$close_in_child) { next unless fileno $fd;