lib/IPC/Open3.pm

   1 package IPC::Open3;
   2 require 5.001;
   3 require Exporter;
   4 use Carp;
   5
   6 =head1 NAME
   7
   8 IPC::Open3, open3 - open a process for reading, writing, and error handling
   9
  10 =head1 SYNOPSIS
  11
  12     $pid = open3('WTRFH', 'RDRFH', 'ERRFH'
  13                     'some cmd and args', 'optarg', ...);
  14
  15 =head1 DESCRIPTION
  16
  17 Extremely similar to open2(), open3() spawns the given $cmd and
  18 connects RDRFH for reading, WTRFH for writing, and ERRFH for errors.  If
  19 ERRFH is '', or the same as RDRFH, then STDOUT and STDERR of the child are
  20 on the same file handle.
  21
  22 If WTRFH begins with "<&", then WTRFH will be closed in the parent, and
  23 the child will read from it directly.  If RDRFH or ERRFH begins with
  24 ">&", then the child will send output directly to that file handle.  In both
  25 cases, there will be a dup(2) instead of a pipe(2) made.
  26
  27 All caveats from open2() continue to apply.  See L<open2> for details.
  28
  29 =cut
  30
  31 @ISA = qw(Exporter);
  32 @EXPORT = qw(open3);
  33
  34 # &open3: Marc Horowitz <marc@mit.edu>
  35 # derived mostly from &open2 by tom christiansen, <tchrist@convex.com>
  36 # fixed for 5.001 by Ulrich Kunitz <kunitz@mai-koeln.com>
  37 #
  38 # $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $
  39 #
  40 # usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...);
  41 #
  42 # spawn the given $cmd and connect rdr for
  43 # reading, wtr for writing, and err for errors.
  44 # if err is '', or the same as rdr, then stdout and
  45 # stderr of the child are on the same fh.  returns pid
  46 # of child, or 0 on failure.
  47
  48
  49 # if wtr begins with '<&', then wtr will be closed in the parent, and
  50 # the child will read from it directly.  if rdr or err begins with
  51 # '>&', then the child will send output directly to that fd.  In both
  52 # cases, there will be a dup() instead of a pipe() made.
  53
  54
  55 # WARNING: this is dangerous, as you may block forever
  56 # unless you are very careful.
  57 #
  58 # $wtr is left unbuffered.
  59 #
  60 # abort program if
  61 #   rdr or wtr are null
  62 #   pipe or fork or exec fails
  63
  64 $fh = 'FHOPEN000';  # package static in case called more than once
  65
  66 sub open3 {
  67     my($kidpid);
  68     my($dad_wtr, $dad_rdr, $dad_err, @cmd) = @_;
  69     my($dup_wtr, $dup_rdr, $dup_err);
  70
  71     $dad_wtr                    || croak "open3: wtr should not be null";
  72     $dad_rdr                    || croak "open3: rdr should not be null";
  73     $dad_err = $dad_rdr if ($dad_err eq '');
  74
  75     $dup_wtr = ($dad_wtr =~ s/^[<>]&//);
  76     $dup_rdr = ($dad_rdr =~ s/^[<>]&//);
  77     $dup_err = ($dad_err =~ s/^[<>]&//);
  78
  79     # force unqualified filehandles into callers' package
  80     my($package) = caller;
  81     $dad_wtr =~ s/^[^:]+$/$package\:\:$&/;
  82     $dad_rdr =~ s/^[^:]+$/$package\:\:$&/;
  83     $dad_err =~ s/^[^:]+$/$package\:\:$&/;
  84
  85     my($kid_rdr) = ++$fh;
  86     my($kid_wtr) = ++$fh;
  87     my($kid_err) = ++$fh;
  88
  89     if (!$dup_wtr) {
  90         pipe($kid_rdr, $dad_wtr)    || croak "open3: pipe 1 (stdin) failed: $!";
  91     }
  92     if (!$dup_rdr) {
  93         pipe($dad_rdr, $kid_wtr)    || croak "open3: pipe 2 (stdout) failed: $!";
  94     }
  95     if ($dad_err ne $dad_rdr && !$dup_err) {
  96         pipe($dad_err, $kid_err)    || croak "open3: pipe 3 (stderr) failed: $!";
  97     }
  98
  99     if (($kidpid = fork) < 0) {
 100         croak "open2: fork failed: $!";
 101     } elsif ($kidpid == 0) {
 102         if ($dup_wtr) {
 103             open(STDIN,  "<&$dad_wtr") if (fileno(STDIN) != fileno($dad_wtr));
 104         } else {
 105             close($dad_wtr);
 106             open(STDIN,  "<&$kid_rdr");
 107         }
 108         if ($dup_rdr) {
 109             open(STDOUT, ">&$dad_rdr") if (fileno(STDOUT) != fileno($dad_rdr));
 110         } else {
 111             close($dad_rdr);
 112             open(STDOUT, ">&$kid_wtr");
 113         }
 114         if ($dad_rdr ne $dad_err) {
 115             if ($dup_err) {
 116                 open(STDERR, ">&$dad_err")
 117                     if (fileno(STDERR) != fileno($dad_err));
 118             } else {
 119                 close($dad_err);
 120                 open(STDERR, ">&$kid_err");
 121             }
 122         } else {
 123             open(STDERR, ">&STDOUT") if (fileno(STDERR) != fileno(STDOUT));
 124         }
 125         local($")=(" ");
 126         exec @cmd;
 127         croak "open2: exec of @cmd failed";
 128     }
 129
 130     close $kid_rdr; close $kid_wtr; close $kid_err;
 131     if ($dup_wtr) {
 132         close($dad_wtr);
 133     }
 134
 135     select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
 136     $kidpid;
 137 }
 138 1; # so require is happy
 139