lib/IPC/Open3.pm

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