lib/open3.pl

   1 # &open3: Marc Horowitz <marc@mit.edu>
   2 # derived mostly from &open2 by tom christiansen, <tchrist@convex.com>
   3 #
   4 # usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...);
   5 #
   6 # spawn the given $cmd and connect rdr for
   7 # reading, wtr for writing, and err for errors.
   8 # if err is '', or the same as rdr, then stdout and
   9 # stderr of the child are on the same fh.  returns pid
  10 # of child, or 0 on failure.
  11
  12
  13 # if wtr begins with '>&', then wtr will be closed in the parent, and
  14 # the child will read from it directly.  if rdr or err begins with
  15 # '>&', then the child will send output directly to that fd.  In both
  16 # cases, there will be a dup() instead of a pipe() made.
  17
  18
  19 # WARNING: this is dangerous, as you may block forever
  20 # unless you are very careful.
  21 #
  22 # $wtr is left unbuffered.
  23 #
  24 # abort program if
  25 #   rdr or wtr are null
  26 #   pipe or fork or exec fails
  27
  28 package open3;
  29
  30 $fh = 'FHOPEN000';  # package static in case called more than once
  31
  32 sub main'open3 {
  33     local($kidpid);
  34     local($dad_wtr, $dad_rdr, $dad_err, @cmd) = @_;
  35     local($dup_wtr, $dup_rdr, $dup_err);
  36
  37     $dad_wtr                    || die "open3: wtr should not be null";
  38     $dad_rdr                    || die "open3: rdr should not be null";
  39     $dad_err = $dad_rdr if ($dad_err eq '');
  40
  41     $dup_wtr = ($dad_wtr =~ s/^\>\&//);
  42     $dup_rdr = ($dad_rdr =~ s/^\>\&//);
  43     $dup_err = ($dad_err =~ s/^\>\&//);
  44
  45     # force unqualified filehandles into callers' package
  46     local($package) = caller;
  47     $dad_wtr =~ s/^[^']+$/$package'$&/;
  48     $dad_rdr =~ s/^[^']+$/$package'$&/;
  49     $dad_err =~ s/^[^']+$/$package'$&/;
  50
  51     local($kid_rdr) = ++$fh;
  52     local($kid_wtr) = ++$fh;
  53     local($kid_err) = ++$fh;
  54
  55     if (!$dup_wtr) {
  56         pipe($kid_rdr, $dad_wtr)    || die "open3: pipe 1 (stdin) failed: $!";
  57     }
  58     if (!$dup_rdr) {
  59         pipe($dad_rdr, $kid_wtr)    || die "open3: pipe 2 (stdout) failed: $!";
  60     }
  61     if ($dad_err ne $dad_rdr && !$dup_err) {
  62         pipe($dad_err, $kid_err)    || die "open3: pipe 3 (stderr) failed: $!";
  63     }
  64
  65     if (($kidpid = fork) < 0) {
  66         die "open2: fork failed: $!";
  67     } elsif ($kidpid == 0) {
  68         if ($dup_wtr) {
  69             open(STDIN,  ">&$dad_wtr") if (fileno(STDIN) != fileno($dad_wtr));
  70         } else {
  71             close($dad_wtr);
  72             open(STDIN,  ">&$kid_rdr");
  73         }
  74         if ($dup_rdr) {
  75             open(STDOUT, ">&$dad_rdr") if (fileno(STDOUT) != fileno($dad_rdr));
  76         } else {
  77             close($dad_rdr);
  78             open(STDOUT, ">&$kid_wtr");
  79         }
  80         if ($dad_rdr ne $dad_err) {
  81             if ($dup_err) {
  82                 open(STDERR, ">&$dad_err")
  83                     if (fileno(STDERR) != fileno($dad_err));
  84             } else {
  85                 close($dad_err);
  86                 open(STDERR, ">&$kid_err");
  87             }
  88         } else {
  89             open(STDERR, ">&STDOUT") if (fileno(STDERR) != fileno(STDOUT));
  90         }
  91         exec @cmd;
  92
  93         local($")=(" ");
  94         die "open2: exec of @cmd failed";
  95     }
  96
  97     close $kid_rdr; close $kid_wtr; close $kid_err;
  98     if ($dup_wtr) {
  99         close($dad_wtr);
 100     }
 101
 102     select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
 103     $kidpid;
 104 }
 105 1; # so require is happy