| 1 | package IPC::Open3;
|
|---|
| 2 |
|
|---|
| 3 | use strict;
|
|---|
| 4 | no strict 'refs'; # because users pass me bareword filehandles
|
|---|
| 5 | our ($VERSION, @ISA, @EXPORT);
|
|---|
| 6 |
|
|---|
| 7 | require Exporter;
|
|---|
| 8 |
|
|---|
| 9 | use Carp;
|
|---|
| 10 | use Symbol qw(gensym qualify);
|
|---|
| 11 |
|
|---|
| 12 | $VERSION = 1.02;
|
|---|
| 13 | @ISA = qw(Exporter);
|
|---|
| 14 | @EXPORT = qw(open3);
|
|---|
| 15 |
|
|---|
| 16 | =head1 NAME
|
|---|
| 17 |
|
|---|
| 18 | IPC::Open3, open3 - open a process for reading, writing, and error handling
|
|---|
| 19 |
|
|---|
| 20 | =head1 SYNOPSIS
|
|---|
| 21 |
|
|---|
| 22 | $pid = open3(\*CHLD_IN, \*CHLD_OUT, \*CHLD_ERR,
|
|---|
| 23 | 'some cmd and args', 'optarg', ...);
|
|---|
| 24 |
|
|---|
| 25 | my($wtr, $rdr, $err);
|
|---|
| 26 | $pid = open3($wtr, $rdr, $err,
|
|---|
| 27 | 'some cmd and args', 'optarg', ...);
|
|---|
| 28 |
|
|---|
| 29 | =head1 DESCRIPTION
|
|---|
| 30 |
|
|---|
| 31 | Extremely similar to open2(), open3() spawns the given $cmd and
|
|---|
| 32 | connects CHLD_OUT for reading from the child, CHLD_IN for writing to
|
|---|
| 33 | the child, and CHLD_ERR for errors. If CHLD_ERR is false, or the
|
|---|
| 34 | same file descriptor as CHLD_OUT, then STDOUT and STDERR of the child
|
|---|
| 35 | are on the same filehandle. The CHLD_IN will have autoflush turned
|
|---|
| 36 | on.
|
|---|
| 37 |
|
|---|
| 38 | If CHLD_IN begins with C<< <& >>, then CHLD_IN will be closed in the
|
|---|
| 39 | parent, and the child will read from it directly. If CHLD_OUT or
|
|---|
| 40 | CHLD_ERR begins with C<< >& >>, then the child will send output
|
|---|
| 41 | directly to that filehandle. In both cases, there will be a dup(2)
|
|---|
| 42 | instead of a pipe(2) made.
|
|---|
| 43 |
|
|---|
| 44 | If either reader or writer is the null string, this will be replaced
|
|---|
| 45 | by an autogenerated filehandle. If so, you must pass a valid lvalue
|
|---|
| 46 | in the parameter slot so it can be overwritten in the caller, or
|
|---|
| 47 | an exception will be raised.
|
|---|
| 48 |
|
|---|
| 49 | The filehandles may also be integers, in which case they are understood
|
|---|
| 50 | as file descriptors.
|
|---|
| 51 |
|
|---|
| 52 | open3() returns the process ID of the child process. It doesn't return on
|
|---|
| 53 | failure: it just raises an exception matching C</^open3:/>. However,
|
|---|
| 54 | C<exec> failures in the child are not detected. You'll have to
|
|---|
| 55 | trap SIGPIPE yourself.
|
|---|
| 56 |
|
|---|
| 57 | Note if you specify C<-> as the command, in an analogous fashion to
|
|---|
| 58 | C<open(FOO, "-|")> the child process will just be the forked Perl
|
|---|
| 59 | process rather than an external command. This feature isn't yet
|
|---|
| 60 | supported on Win32 platforms.
|
|---|
| 61 |
|
|---|
| 62 | open3() does not wait for and reap the child process after it exits.
|
|---|
| 63 | Except for short programs where it's acceptable to let the operating system
|
|---|
| 64 | take care of this, you need to do this yourself. This is normally as
|
|---|
| 65 | simple as calling C<waitpid $pid, 0> when you're done with the process.
|
|---|
| 66 | Failing to do this can result in an accumulation of defunct or "zombie"
|
|---|
| 67 | processes. See L<perlfunc/waitpid> for more information.
|
|---|
| 68 |
|
|---|
| 69 | If you try to read from the child's stdout writer and their stderr
|
|---|
| 70 | writer, you'll have problems with blocking, which means you'll want
|
|---|
| 71 | to use select() or the IO::Select, which means you'd best use
|
|---|
| 72 | sysread() instead of readline() for normal stuff.
|
|---|
| 73 |
|
|---|
| 74 | This is very dangerous, as you may block forever. It assumes it's
|
|---|
| 75 | going to talk to something like B<bc>, both writing to it and reading
|
|---|
| 76 | from it. This is presumably safe because you "know" that commands
|
|---|
| 77 | like B<bc> will read a line at a time and output a line at a time.
|
|---|
| 78 | Programs like B<sort> that read their entire input stream first,
|
|---|
| 79 | however, are quite apt to cause deadlock.
|
|---|
| 80 |
|
|---|
| 81 | The big problem with this approach is that if you don't have control
|
|---|
| 82 | over source code being run in the child process, you can't control
|
|---|
| 83 | what it does with pipe buffering. Thus you can't just open a pipe to
|
|---|
| 84 | C<cat -v> and continually read and write a line from it.
|
|---|
| 85 |
|
|---|
| 86 | =head1 WARNING
|
|---|
| 87 |
|
|---|
| 88 | The order of arguments differs from that of open2().
|
|---|
| 89 |
|
|---|
| 90 | =cut
|
|---|
| 91 |
|
|---|
| 92 | # &open3: Marc Horowitz <[email protected]>
|
|---|
| 93 | # derived mostly from &open2 by tom christiansen, <[email protected]>
|
|---|
| 94 | # fixed for 5.001 by Ulrich Kunitz <[email protected]>
|
|---|
| 95 | # ported to Win32 by Ron Schmidt, Merrill Lynch almost ended my career
|
|---|
| 96 | # fixed for autovivving FHs, tchrist again
|
|---|
| 97 | # allow fd numbers to be used, by Frank Tobin
|
|---|
| 98 | # allow '-' as command (c.f. open "-|"), by Adam Spiers <[email protected]>
|
|---|
| 99 | #
|
|---|
| 100 | # $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $
|
|---|
| 101 | #
|
|---|
| 102 | # usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...);
|
|---|
| 103 | #
|
|---|
| 104 | # spawn the given $cmd and connect rdr for
|
|---|
| 105 | # reading, wtr for writing, and err for errors.
|
|---|
| 106 | # if err is '', or the same as rdr, then stdout and
|
|---|
| 107 | # stderr of the child are on the same fh. returns pid
|
|---|
| 108 | # of child (or dies on failure).
|
|---|
| 109 |
|
|---|
| 110 |
|
|---|
| 111 | # if wtr begins with '<&', then wtr will be closed in the parent, and
|
|---|
| 112 | # the child will read from it directly. if rdr or err begins with
|
|---|
| 113 | # '>&', then the child will send output directly to that fd. In both
|
|---|
| 114 | # cases, there will be a dup() instead of a pipe() made.
|
|---|
| 115 |
|
|---|
| 116 |
|
|---|
| 117 | # WARNING: this is dangerous, as you may block forever
|
|---|
| 118 | # unless you are very careful.
|
|---|
| 119 | #
|
|---|
| 120 | # $wtr is left unbuffered.
|
|---|
| 121 | #
|
|---|
| 122 | # abort program if
|
|---|
| 123 | # rdr or wtr are null
|
|---|
| 124 | # a system call fails
|
|---|
| 125 |
|
|---|
| 126 | our $Me = 'open3 (bug)'; # you should never see this, it's always localized
|
|---|
| 127 |
|
|---|
| 128 | # Fatal.pm needs to be fixed WRT prototypes.
|
|---|
| 129 |
|
|---|
| 130 | sub xfork {
|
|---|
| 131 | my $pid = fork;
|
|---|
| 132 | defined $pid or croak "$Me: fork failed: $!";
|
|---|
| 133 | return $pid;
|
|---|
| 134 | }
|
|---|
| 135 |
|
|---|
| 136 | sub xpipe {
|
|---|
| 137 | pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!";
|
|---|
| 138 | }
|
|---|
| 139 |
|
|---|
| 140 | # I tried using a * prototype character for the filehandle but it still
|
|---|
| 141 | # disallows a bearword while compiling under strict subs.
|
|---|
| 142 |
|
|---|
| 143 | sub xopen {
|
|---|
| 144 | open $_[0], $_[1] or croak "$Me: open($_[0], $_[1]) failed: $!";
|
|---|
| 145 | }
|
|---|
| 146 |
|
|---|
| 147 | sub xclose {
|
|---|
| 148 | close $_[0] or croak "$Me: close($_[0]) failed: $!";
|
|---|
| 149 | }
|
|---|
| 150 |
|
|---|
| 151 | sub fh_is_fd {
|
|---|
| 152 | return $_[0] =~ /\A=?(\d+)\z/;
|
|---|
| 153 | }
|
|---|
| 154 |
|
|---|
| 155 | sub xfileno {
|
|---|
| 156 | return $1 if $_[0] =~ /\A=?(\d+)\z/; # deal with fh just being an fd
|
|---|
| 157 | return fileno $_[0];
|
|---|
| 158 | }
|
|---|
| 159 |
|
|---|
| 160 | my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32';
|
|---|
| 161 |
|
|---|
| 162 | sub _open3 {
|
|---|
| 163 | local $Me = shift;
|
|---|
| 164 | my($package, $dad_wtr, $dad_rdr, $dad_err, @cmd) = @_;
|
|---|
| 165 | my($dup_wtr, $dup_rdr, $dup_err, $kidpid);
|
|---|
| 166 |
|
|---|
| 167 | # simulate autovivification of filehandles because
|
|---|
| 168 | # it's too ugly to use @_ throughout to make perl do it for us
|
|---|
| 169 | # tchrist 5-Mar-00
|
|---|
| 170 |
|
|---|
| 171 | unless (eval {
|
|---|
| 172 | $dad_wtr = $_[1] = gensym unless defined $dad_wtr && length $dad_wtr;
|
|---|
| 173 | $dad_rdr = $_[2] = gensym unless defined $dad_rdr && length $dad_rdr;
|
|---|
| 174 | 1; })
|
|---|
| 175 | {
|
|---|
| 176 | # must strip crud for croak to add back, or looks ugly
|
|---|
| 177 | $@ =~ s/(?<=value attempted) at .*//s;
|
|---|
| 178 | croak "$Me: $@";
|
|---|
| 179 | }
|
|---|
| 180 |
|
|---|
| 181 | $dad_err ||= $dad_rdr;
|
|---|
| 182 |
|
|---|
| 183 | $dup_wtr = ($dad_wtr =~ s/^[<>]&//);
|
|---|
| 184 | $dup_rdr = ($dad_rdr =~ s/^[<>]&//);
|
|---|
| 185 | $dup_err = ($dad_err =~ s/^[<>]&//);
|
|---|
| 186 |
|
|---|
| 187 | # force unqualified filehandles into caller's package
|
|---|
| 188 | $dad_wtr = qualify $dad_wtr, $package unless fh_is_fd($dad_wtr);
|
|---|
| 189 | $dad_rdr = qualify $dad_rdr, $package unless fh_is_fd($dad_rdr);
|
|---|
| 190 | $dad_err = qualify $dad_err, $package unless fh_is_fd($dad_err);
|
|---|
| 191 |
|
|---|
| 192 | my $kid_rdr = gensym;
|
|---|
| 193 | my $kid_wtr = gensym;
|
|---|
| 194 | my $kid_err = gensym;
|
|---|
| 195 |
|
|---|
| 196 | xpipe $kid_rdr, $dad_wtr if !$dup_wtr;
|
|---|
| 197 | xpipe $dad_rdr, $kid_wtr if !$dup_rdr;
|
|---|
| 198 | xpipe $dad_err, $kid_err if !$dup_err && $dad_err ne $dad_rdr;
|
|---|
| 199 |
|
|---|
| 200 | $kidpid = $do_spawn ? -1 : xfork;
|
|---|
| 201 | if ($kidpid == 0) { # Kid
|
|---|
| 202 | # A tie in the parent should not be allowed to cause problems.
|
|---|
| 203 | untie *STDIN;
|
|---|
| 204 | untie *STDOUT;
|
|---|
| 205 | # If she wants to dup the kid's stderr onto her stdout I need to
|
|---|
| 206 | # save a copy of her stdout before I put something else there.
|
|---|
| 207 | if ($dad_rdr ne $dad_err && $dup_err
|
|---|
| 208 | && xfileno($dad_err) == fileno(STDOUT)) {
|
|---|
| 209 | my $tmp = gensym;
|
|---|
| 210 | xopen($tmp, ">&$dad_err");
|
|---|
| 211 | $dad_err = $tmp;
|
|---|
| 212 | }
|
|---|
| 213 |
|
|---|
| 214 | if ($dup_wtr) {
|
|---|
| 215 | xopen \*STDIN, "<&$dad_wtr" if fileno(STDIN) != xfileno($dad_wtr);
|
|---|
| 216 | } else {
|
|---|
| 217 | xclose $dad_wtr;
|
|---|
| 218 | xopen \*STDIN, "<&=" . fileno $kid_rdr;
|
|---|
| 219 | }
|
|---|
| 220 | if ($dup_rdr) {
|
|---|
| 221 | xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != xfileno($dad_rdr);
|
|---|
| 222 | } else {
|
|---|
| 223 | xclose $dad_rdr;
|
|---|
| 224 | xopen \*STDOUT, ">&=" . fileno $kid_wtr;
|
|---|
| 225 | }
|
|---|
| 226 | if ($dad_rdr ne $dad_err) {
|
|---|
| 227 | if ($dup_err) {
|
|---|
| 228 | # I have to use a fileno here because in this one case
|
|---|
| 229 | # I'm doing a dup but the filehandle might be a reference
|
|---|
| 230 | # (from the special case above).
|
|---|
| 231 | xopen \*STDERR, ">&" . xfileno($dad_err)
|
|---|
| 232 | if fileno(STDERR) != xfileno($dad_err);
|
|---|
| 233 | } else {
|
|---|
| 234 | xclose $dad_err;
|
|---|
| 235 | xopen \*STDERR, ">&=" . fileno $kid_err;
|
|---|
| 236 | }
|
|---|
| 237 | } else {
|
|---|
| 238 | xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT);
|
|---|
| 239 | }
|
|---|
| 240 | if ($cmd[0] eq '-') {
|
|---|
| 241 | croak "Arguments don't make sense when the command is '-'"
|
|---|
| 242 | if @cmd > 1;
|
|---|
| 243 | return 0;
|
|---|
| 244 | }
|
|---|
| 245 | local($")=(" ");
|
|---|
| 246 | exec @cmd # XXX: wrong process to croak from
|
|---|
| 247 | or croak "$Me: exec of @cmd failed";
|
|---|
| 248 | } elsif ($do_spawn) {
|
|---|
| 249 | # All the bookkeeping of coincidence between handles is
|
|---|
| 250 | # handled in spawn_with_handles.
|
|---|
| 251 |
|
|---|
| 252 | my @close;
|
|---|
| 253 | if ($dup_wtr) {
|
|---|
| 254 | $kid_rdr = \*{$dad_wtr};
|
|---|
| 255 | push @close, $kid_rdr;
|
|---|
| 256 | } else {
|
|---|
| 257 | push @close, \*{$dad_wtr}, $kid_rdr;
|
|---|
| 258 | }
|
|---|
| 259 | if ($dup_rdr) {
|
|---|
| 260 | $kid_wtr = \*{$dad_rdr};
|
|---|
| 261 | push @close, $kid_wtr;
|
|---|
| 262 | } else {
|
|---|
| 263 | push @close, \*{$dad_rdr}, $kid_wtr;
|
|---|
| 264 | }
|
|---|
| 265 | if ($dad_rdr ne $dad_err) {
|
|---|
| 266 | if ($dup_err) {
|
|---|
| 267 | $kid_err = \*{$dad_err};
|
|---|
| 268 | push @close, $kid_err;
|
|---|
| 269 | } else {
|
|---|
| 270 | push @close, \*{$dad_err}, $kid_err;
|
|---|
| 271 | }
|
|---|
| 272 | } else {
|
|---|
| 273 | $kid_err = $kid_wtr;
|
|---|
| 274 | }
|
|---|
| 275 | require IO::Pipe;
|
|---|
| 276 | $kidpid = eval {
|
|---|
| 277 | spawn_with_handles( [ { mode => 'r',
|
|---|
| 278 | open_as => $kid_rdr,
|
|---|
| 279 | handle => \*STDIN },
|
|---|
| 280 | { mode => 'w',
|
|---|
| 281 | open_as => $kid_wtr,
|
|---|
| 282 | handle => \*STDOUT },
|
|---|
| 283 | { mode => 'w',
|
|---|
| 284 | open_as => $kid_err,
|
|---|
| 285 | handle => \*STDERR },
|
|---|
| 286 | ], \@close, @cmd);
|
|---|
| 287 | };
|
|---|
| 288 | die "$Me: $@" if $@;
|
|---|
| 289 | }
|
|---|
| 290 |
|
|---|
| 291 | xclose $kid_rdr if !$dup_wtr;
|
|---|
| 292 | xclose $kid_wtr if !$dup_rdr;
|
|---|
| 293 | xclose $kid_err if !$dup_err && $dad_rdr ne $dad_err;
|
|---|
| 294 | # If the write handle is a dup give it away entirely, close my copy
|
|---|
| 295 | # of it.
|
|---|
| 296 | xclose $dad_wtr if $dup_wtr;
|
|---|
| 297 |
|
|---|
| 298 | select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
|
|---|
| 299 | $kidpid;
|
|---|
| 300 | }
|
|---|
| 301 |
|
|---|
| 302 | sub open3 {
|
|---|
| 303 | if (@_ < 4) {
|
|---|
| 304 | local $" = ', ';
|
|---|
| 305 | croak "open3(@_): not enough arguments";
|
|---|
| 306 | }
|
|---|
| 307 | return _open3 'open3', scalar caller, @_
|
|---|
| 308 | }
|
|---|
| 309 |
|
|---|
| 310 | sub spawn_with_handles {
|
|---|
| 311 | my $fds = shift; # Fields: handle, mode, open_as
|
|---|
| 312 | my $close_in_child = shift;
|
|---|
| 313 | my ($fd, $pid, @saved_fh, $saved, %saved, @errs);
|
|---|
| 314 | require Fcntl;
|
|---|
| 315 |
|
|---|
| 316 | foreach $fd (@$fds) {
|
|---|
| 317 | $fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode});
|
|---|
| 318 | $saved{fileno $fd->{handle}} = $fd->{tmp_copy};
|
|---|
| 319 | }
|
|---|
| 320 | foreach $fd (@$fds) {
|
|---|
| 321 | bless $fd->{handle}, 'IO::Handle'
|
|---|
| 322 | unless eval { $fd->{handle}->isa('IO::Handle') } ;
|
|---|
| 323 | # If some of handles to redirect-to coincide with handles to
|
|---|
| 324 | # redirect, we need to use saved variants:
|
|---|
| 325 | $fd->{handle}->fdopen($saved{fileno $fd->{open_as}} || $fd->{open_as},
|
|---|
| 326 | $fd->{mode});
|
|---|
| 327 | }
|
|---|
| 328 | unless ($^O eq 'MSWin32') {
|
|---|
| 329 | # Stderr may be redirected below, so we save the err text:
|
|---|
| 330 | foreach $fd (@$close_in_child) {
|
|---|
| 331 | fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!"
|
|---|
| 332 | unless $saved{fileno $fd}; # Do not close what we redirect!
|
|---|
| 333 | }
|
|---|
| 334 | }
|
|---|
| 335 |
|
|---|
| 336 | unless (@errs) {
|
|---|
| 337 | $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
|
|---|
| 338 | push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!" if !$pid || $pid < 0;
|
|---|
| 339 | }
|
|---|
| 340 |
|
|---|
| 341 | foreach $fd (@$fds) {
|
|---|
| 342 | $fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode});
|
|---|
| 343 | $fd->{tmp_copy}->close or croak "Can't close: $!";
|
|---|
| 344 | }
|
|---|
| 345 | croak join "\n", @errs if @errs;
|
|---|
| 346 | return $pid;
|
|---|
| 347 | }
|
|---|
| 348 |
|
|---|
| 349 | 1; # so require is happy
|
|---|
