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