perl 5.000perl-5.000

[editor's note: this commit combines approximate 4 months of furious
releases of Andy Dougherty and Larry Wall - see pod/perlhist.pod for
details.  Andy notes that;
 
Alas neither my "Irwin AccuTrack" nor my DC 600A quarter-inch cartridge 
backup tapes from that era seem to be readable anymore.  I guess 13 years 
exceeds the shelf life for that backup technology :-(.
]

2 files changed, 175 insertions, 0 deletions

diff --git a/lib/IPC/Open2.pm b/lib/IPC/Open2.pm
new file mode 100644
index 0000000000..c59c7d6897
--- /dev/null
+++ b/lib/IPC/Open2.pm
@@ -0,0 +1,62 @@
+package IPC::Open2;
+require 5.000;
+require Exporter;
+use Carp;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(open2);
+
+# &open2: tom christiansen, <tchrist@convex.com>
+#
+# usage: $pid = open2('rdr', 'wtr', 'some cmd and args');
+#    or  $pid = open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args');
+#
+# spawn the given $cmd and connect $rdr for
+# reading and $wtr for writing.  return pid
+# of child, or 0 on failure.  
+# 
+# WARNING: this is dangerous, as you may block forever
+# unless you are very careful.  
+# 
+# $wtr is left unbuffered.
+# 
+# abort program if
+#	rdr or wtr are null
+# 	pipe or fork or exec fails
+
+$fh = 'FHOPEN000';  # package static in case called more than once
+
+sub open2 {
+    local($kidpid);
+    local($dad_rdr, $dad_wtr, @cmd) = @_;
+
+    $dad_rdr ne '' 		|| croak "open2: rdr should not be null";
+    $dad_wtr ne '' 		|| croak "open2: wtr should not be null";
+
+    # force unqualified filehandles into callers' package
+    local($package) = caller;
+    $dad_rdr =~ s/^[^']+$/$package'$&/;
+    $dad_wtr =~ s/^[^']+$/$package'$&/;
+
+    local($kid_rdr) = ++$fh;
+    local($kid_wtr) = ++$fh;
+
+    pipe($dad_rdr, $kid_wtr) 	|| croak "open2: pipe 1 failed: $!";
+    pipe($kid_rdr, $dad_wtr) 	|| croak "open2: pipe 2 failed: $!";
+
+    if (($kidpid = fork) < 0) {
+	croak "open2: fork failed: $!";
+    } elsif ($kidpid == 0) {
+	close $dad_rdr; close $dad_wtr;
+	open(STDIN,  "<&$kid_rdr");
+	open(STDOUT, ">&$kid_wtr");
+	warn "execing @cmd\n" if $debug;
+	exec @cmd;
+	croak "open2: exec of @cmd failed";   
+    } 
+    close $kid_rdr; close $kid_wtr;
+    select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
+    $kidpid;
+}
+1; # so require is happy
+
diff --git a/lib/IPC/Open3.pm b/lib/IPC/Open3.pm
new file mode 100644
index 0000000000..3426f19111
--- /dev/null
+++ b/lib/IPC/Open3.pm
@@ -0,0 +1,113 @@
+package IPC::Open3;
+require 5.000;
+require Exporter;
+use Carp;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(open3);
+
+# &open3: Marc Horowitz <marc@mit.edu>
+# derived mostly from &open2 by tom christiansen, <tchrist@convex.com>
+#
+# $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $
+#
+# usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...);
+#
+# spawn the given $cmd and connect rdr for
+# reading, wtr for writing, and err for errors.
+# if err is '', or the same as rdr, then stdout and
+# stderr of the child are on the same fh.  returns pid
+# of child, or 0 on failure.
+
+
+# if wtr begins with '>&', then wtr will be closed in the parent, and
+# the child will read from it directly.  if rdr or err begins with
+# '>&', then the child will send output directly to that fd.  In both
+# cases, there will be a dup() instead of a pipe() made.
+
+
+# WARNING: this is dangerous, as you may block forever
+# unless you are very careful.
+#
+# $wtr is left unbuffered.
+#
+# abort program if
+#   rdr or wtr are null
+#   pipe or fork or exec fails
+
+$fh = 'FHOPEN000';  # package static in case called more than once
+
+sub open3 {
+    local($kidpid);
+    local($dad_wtr, $dad_rdr, $dad_err, @cmd) = @_;
+    local($dup_wtr, $dup_rdr, $dup_err);
+
+    $dad_wtr			|| croak "open3: wtr should not be null";
+    $dad_rdr			|| croak "open3: rdr should not be null";
+    $dad_err = $dad_rdr if ($dad_err eq '');
+
+    $dup_wtr = ($dad_wtr =~ s/^\>\&//);
+    $dup_rdr = ($dad_rdr =~ s/^\>\&//);
+    $dup_err = ($dad_err =~ s/^\>\&//);
+
+    # force unqualified filehandles into callers' package
+    local($package) = caller;
+    $dad_wtr =~ s/^[^']+$/$package'$&/;
+    $dad_rdr =~ s/^[^']+$/$package'$&/;
+    $dad_err =~ s/^[^']+$/$package'$&/;
+
+    local($kid_rdr) = ++$fh;
+    local($kid_wtr) = ++$fh;
+    local($kid_err) = ++$fh;
+
+    if (!$dup_wtr) {
+	pipe($kid_rdr, $dad_wtr)    || croak "open3: pipe 1 (stdin) failed: $!";
+    }
+    if (!$dup_rdr) {
+	pipe($dad_rdr, $kid_wtr)    || croak "open3: pipe 2 (stdout) failed: $!";
+    }
+    if ($dad_err ne $dad_rdr && !$dup_err) {
+	pipe($dad_err, $kid_err)    || croak "open3: pipe 3 (stderr) failed: $!";
+    }
+
+    if (($kidpid = fork) < 0) {
+        croak "open2: fork failed: $!";
+    } elsif ($kidpid == 0) {
+	if ($dup_wtr) {
+	    open(STDIN,  ">&$dad_wtr") if (fileno(STDIN) != fileno($dad_wtr));
+	} else {
+	    close($dad_wtr);
+	    open(STDIN,  ">&$kid_rdr");
+	}
+	if ($dup_rdr) {
+	    open(STDOUT, ">&$dad_rdr") if (fileno(STDOUT) != fileno($dad_rdr));
+	} else {
+	    close($dad_rdr);
+	    open(STDOUT, ">&$kid_wtr");
+	}
+	if ($dad_rdr ne $dad_err) {
+	    if ($dup_err) {
+		open(STDERR, ">&$dad_err")
+		    if (fileno(STDERR) != fileno($dad_err));
+	    } else {
+		close($dad_err);
+		open(STDERR, ">&$kid_err");
+	    }
+	} else {
+	    open(STDERR, ">&STDOUT") if (fileno(STDERR) != fileno(STDOUT));
+	}
+	local($")=(" ");
+	exec @cmd;
+        croak "open2: exec of @cmd failed";
+    }
+
+    close $kid_rdr; close $kid_wtr; close $kid_err;
+    if ($dup_wtr) {
+	close($dad_wtr);
+    }
+
+    select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
+    $kidpid;
+}
+1; # so require is happy
+