[Summary view] [Print] [Text view]

   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