use Carp;
use Symbol qw(gensym qualify);
-$VERSION = '1.11';
+$VERSION = '1.16';
@ISA = qw(Exporter);
@EXPORT = qw(open3);
open3() returns the process ID of the child process. It doesn't return on
failure: it just raises an exception matching C</^open3:/>. However,
C<exec> 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.
=item L<IPC::Open2>
-Like Open3 but without STDERR catpure.
+Like Open3 but without STDERR capture.
=item L<IPC::Run>
# 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.
}
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];
# 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];
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.
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 = $@;
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 {
# 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;
}
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});
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;
https://perl5.git.perl.org / perl5.git / blobdiff