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.0106;
  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         # A tie in the parent should not be allowed to cause problems.
 201         untie *STDIN;
 202         untie *STDOUT;
 203         # If she wants to dup the kid's stderr onto her stdout I need to
 204         # save a copy of her stdout before I put something else there.
 205         if ($dad_rdr ne $dad_err && $dup_err
 206                 && xfileno($dad_err) == fileno(STDOUT)) {
 207             my $tmp = gensym;
 208             xopen($tmp, ">&$dad_err");
 209             $dad_err = $tmp;
 210         }
 211
 212         if ($dup_wtr) {
 213             xopen \*STDIN,  "<&$dad_wtr" if fileno(STDIN) != xfileno($dad_wtr);
 214         } else {
 215             xclose $dad_wtr;
 216             xopen \*STDIN,  "<&=" . fileno $kid_rdr;
 217         }
 218         if ($dup_rdr) {
 219             xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != xfileno($dad_rdr);
 220         } else {
 221             xclose $dad_rdr;
 222             xopen \*STDOUT, ">&=" . fileno $kid_wtr;
 223         }
 224         if ($dad_rdr ne $dad_err) {
 225             if ($dup_err) {
 226                 # I have to use a fileno here because in this one case
 227                 # I'm doing a dup but the filehandle might be a reference
 228                 # (from the special case above).
 229                 xopen \*STDERR, ">&" . xfileno($dad_err)
 230                     if fileno(STDERR) != xfileno($dad_err);
 231             } else {
 232                 xclose $dad_err;
 233                 xopen \*STDERR, ">&=" . fileno $kid_err;
 234             }
 235         } else {
 236             xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT);
 237         }
 238         if ($cmd[0] eq '-') {
 239             croak "Arguments don't make sense when the command is '-'"
 240               if @cmd > 1;
 241             return 0;
 242         }
 243         local($")=(" ");
 244         exec @cmd # XXX: wrong process to croak from
 245             or croak "$Me: exec of @cmd failed";
 246     } elsif ($do_spawn) {
 247         # All the bookkeeping of coincidence between handles is
 248         # handled in spawn_with_handles.
 249
 250         my @close;
 251         if ($dup_wtr) {
 252           $kid_rdr = \*{$dad_wtr};
 253           push @close, $kid_rdr;
 254         } else {
 255           push @close, \*{$dad_wtr}, $kid_rdr;
 256         }
 257         if ($dup_rdr) {
 258           $kid_wtr = \*{$dad_rdr};
 259           push @close, $kid_wtr;
 260         } else {
 261           push @close, \*{$dad_rdr}, $kid_wtr;
 262         }
 263         if ($dad_rdr ne $dad_err) {
 264             if ($dup_err) {
 265               $kid_err = \*{$dad_err};
 266               push @close, $kid_err;
 267             } else {
 268               push @close, \*{$dad_err}, $kid_err;
 269             }
 270         } else {
 271           $kid_err = $kid_wtr;
 272         }
 273         require IO::Pipe;
 274         $kidpid = eval {
 275             spawn_with_handles( [ { mode => 'r',
 276                                     open_as => $kid_rdr,
 277                                     handle => \*STDIN },
 278                                   { mode => 'w',
 279                                     open_as => $kid_wtr,
 280                                     handle => \*STDOUT },
 281                                   { mode => 'w',
 282                                     open_as => $kid_err,
 283                                     handle => \*STDERR },
 284                                 ], \@close, @cmd);
 285         };
 286         die "$Me: $@" if $@;
 287     }
 288
 289     xclose $kid_rdr if !$dup_wtr;
 290     xclose $kid_wtr if !$dup_rdr;
 291     xclose $kid_err if !$dup_err && $dad_rdr ne $dad_err;
 292     # If the write handle is a dup give it away entirely, close my copy
 293     # of it.
 294     xclose $dad_wtr if $dup_wtr;
 295
 296     select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
 297     $kidpid;
 298 }
 299
 300 sub open3 {
 301     if (@_ < 4) {
 302         local $" = ', ';
 303         croak "open3(@_): not enough arguments";
 304     }
 305     return _open3 'open3', scalar caller, @_
 306 }
 307
 308 sub spawn_with_handles {
 309     my $fds = shift;            # Fields: handle, mode, open_as
 310     my $close_in_child = shift;
 311     my ($fd, $pid, @saved_fh, $saved, %saved, @errs);
 312     require Fcntl;
 313
 314     foreach $fd (@$fds) {
 315         $fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode});
 316         $saved{fileno $fd->{handle}} = $fd->{tmp_copy};
 317     }
 318     foreach $fd (@$fds) {
 319         bless $fd->{handle}, 'IO::Handle'
 320             unless eval { $fd->{handle}->isa('IO::Handle') } ;
 321         # If some of handles to redirect-to coincide with handles to
 322         # redirect, we need to use saved variants:
 323         $fd->{handle}->fdopen($saved{fileno $fd->{open_as}} || $fd->{open_as},
 324                               $fd->{mode});
 325     }
 326     unless ($^O eq 'MSWin32') {
 327         # Stderr may be redirected below, so we save the err text:
 328         foreach $fd (@$close_in_child) {
 329             fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!"
 330                 unless $saved{fileno $fd}; # Do not close what we redirect!
 331         }
 332     }
 333
 334     unless (@errs) {
 335         $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
 336         push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!" if !$pid || $pid < 0;
 337     }
 338
 339     foreach $fd (@$fds) {
 340         $fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode});
 341         $fd->{tmp_copy}->close or croak "Can't close: $!";
 342     }
 343     croak join "\n", @errs if @errs;
 344     return $pid;
 345 }
 346
 347 1; # so require is happy