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