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