summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/IPC/Open3.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/IPC/Open3.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/IPC/Open3.pm153
1 files changed, 99 insertions, 54 deletions
diff --git a/Master/tlpkg/tlperl/lib/IPC/Open3.pm b/Master/tlpkg/tlperl/lib/IPC/Open3.pm
index 82c20ae8287..7015d27a789 100644
--- a/Master/tlpkg/tlperl/lib/IPC/Open3.pm
+++ b/Master/tlpkg/tlperl/lib/IPC/Open3.pm
@@ -9,7 +9,7 @@ require Exporter;
use Carp;
use Symbol qw(gensym qualify);
-$VERSION = 1.05;
+$VERSION = 1.09;
@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.
@@ -121,8 +121,6 @@ The order of arguments differs from that of open2().
# allow fd numbers to be used, by Frank Tobin
# allow '-' as command (c.f. open "-|"), by Adam Spiers <perl@adamspiers.org>
#
-# $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $
-#
# usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...);
#
# spawn the given $cmd and connect rdr for
@@ -161,15 +159,27 @@ 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.
+# disallows a bareword while compiling under strict subs.
sub xopen {
open $_[0], $_[1] or croak "$Me: open($_[0], $_[1]) failed: $!";
}
sub xclose {
- close $_[0] or croak "$Me: close($_[0]) failed: $!";
+ $_[0] =~ /\A=?(\d+)\z/ ? eval { require POSIX; POSIX::close($1); } : close $_[0]
}
sub fh_is_fd {
@@ -199,12 +209,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 +235,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.