This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
da925182e77c76718871e37a7939f6f10ab2ec52
[perl5.git] / lib / IPC / Open3.pm
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.0106;
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(\*WTRFH, \*RDRFH, \*ERRFH,
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 RDRFH for reading, WTRFH for writing, and ERRFH for errors.  If
33 ERRFH is false, or the same file descriptor as RDRFH, then STDOUT and 
34 STDERR of the child are on the same filehandle.  The WTRFH will have
35 autoflush turned on.
36
37 If WTRFH begins with C<< <& >>, then WTRFH will be closed in the parent, and
38 the child will read from it directly.  If RDRFH or ERRFH begins with
39 C<< >& >>, then the child will send output directly to that filehandle.
40 In both cases, there will be a dup(2) instead of a pipe(2) made.
41
42 If either reader or writer is the null string, this will be replaced
43 by an autogenerated filehandle.  If so, you must pass a valid lvalue
44 in the parameter slot so it can be overwritten in the caller, or 
45 an exception will be raised.
46
47 The filehandles may also be integers, in which case they are understood
48 as file descriptors.
49
50 open3() returns the process ID of the child process.  It doesn't return on
51 failure: it just raises an exception matching C</^open3:/>.  However,
52 C<exec> failures in the child are not detected.  You'll have to 
53 trap SIGPIPE yourself.
54
55 Note if you specify C<-> as the command, in an analogous fashion to
56 C<open(FOO, "-|")> the child process will just be the forked Perl
57 process rather than an external command.  This feature isn't yet
58 supported on Win32 platforms.
59
60 open3() does not wait for and reap the child process after it exits.  
61 Except for short programs where it's acceptable to let the operating system
62 take care of this, you need to do this yourself.  This is normally as 
63 simple as calling C<waitpid $pid, 0> when you're done with the process.
64 Failing to do this can result in an accumulation of defunct or "zombie"
65 processes.  See L<perlfunc/waitpid> for more information.
66
67 If you try to read from the child's stdout writer and their stderr
68 writer, you'll have problems with blocking, which means you'll want
69 to use select() or the IO::Select, which means you'd best use
70 sysread() instead of readline() for normal stuff.
71
72 This is very dangerous, as you may block forever.  It assumes it's
73 going to talk to something like B<bc>, both writing to it and reading
74 from it.  This is presumably safe because you "know" that commands
75 like B<bc> will read a line at a time and output a line at a time.
76 Programs like B<sort> that read their entire input stream first,
77 however, are quite apt to cause deadlock.
78
79 The big problem with this approach is that if you don't have control
80 over source code being run in the child process, you can't control
81 what it does with pipe buffering.  Thus you can't just open a pipe to
82 C<cat -v> and continually read and write a line from it.
83
84 =head1 WARNING
85
86 The order of arguments differs from that of open2().
87
88 =cut
89
90 # &open3: Marc Horowitz <marc@mit.edu>
91 # derived mostly from &open2 by tom christiansen, <tchrist@convex.com>
92 # fixed for 5.001 by Ulrich Kunitz <kunitz@mai-koeln.com>
93 # ported to Win32 by Ron Schmidt, Merrill Lynch almost ended my career
94 # fixed for autovivving FHs, tchrist again
95 # allow fd numbers to be used, by Frank Tobin
96 # allow '-' as command (c.f. open "-|"), by Adam Spiers <perl@adamspiers.org>
97 #
98 # $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $
99 #
100 # usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...);
101 #
102 # spawn the given $cmd and connect rdr for
103 # reading, wtr for writing, and err for errors.
104 # if err is '', or the same as rdr, then stdout and
105 # stderr of the child are on the same fh.  returns pid
106 # of child (or dies on failure).
107
108
109 # if wtr begins with '<&', then wtr will be closed in the parent, and
110 # the child will read from it directly.  if rdr or err begins with
111 # '>&', then the child will send output directly to that fd.  In both
112 # cases, there will be a dup() instead of a pipe() made.
113
114
115 # WARNING: this is dangerous, as you may block forever
116 # unless you are very careful.
117 #
118 # $wtr is left unbuffered.
119 #
120 # abort program if
121 #   rdr or wtr are null
122 #   a system call fails
123
124 our $Me = 'open3 (bug)';        # you should never see this, it's always localized
125
126 # Fatal.pm needs to be fixed WRT prototypes.
127
128 sub xfork {
129     my $pid = fork;
130     defined $pid or croak "$Me: fork failed: $!";
131     return $pid;
132 }
133
134 sub xpipe {
135     pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!";
136 }
137
138 # I tried using a * prototype character for the filehandle but it still
139 # disallows a bearword while compiling under strict subs.
140
141 sub xopen {
142     open $_[0], $_[1] or croak "$Me: open($_[0], $_[1]) failed: $!";
143 }
144
145 sub xclose {
146     close $_[0] or croak "$Me: close($_[0]) failed: $!";
147 }
148
149 sub fh_is_fd {
150     return $_[0] =~ /\A=?(\d+)\z/;
151 }
152
153 sub xfileno {
154     return $1 if $_[0] =~ /\A=?(\d+)\z/;  # deal with fh just being an fd
155     return fileno $_[0];
156 }
157
158 my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32';
159
160 sub _open3 {
161     local $Me = shift;
162     my($package, $dad_wtr, $dad_rdr, $dad_err, @cmd) = @_;
163     my($dup_wtr, $dup_rdr, $dup_err, $kidpid);
164
165     # simulate autovivification of filehandles because
166     # it's too ugly to use @_ throughout to make perl do it for us
167     # tchrist 5-Mar-00
168
169     unless (eval  {
170         $dad_wtr = $_[1] = gensym unless defined $dad_wtr && length $dad_wtr;
171         $dad_rdr = $_[2] = gensym unless defined $dad_rdr && length $dad_rdr;
172         1; }) 
173     {
174         # must strip crud for croak to add back, or looks ugly
175         $@ =~ s/(?<=value attempted) at .*//s;
176         croak "$Me: $@";
177     } 
178
179     $dad_err ||= $dad_rdr;
180
181     $dup_wtr = ($dad_wtr =~ s/^[<>]&//);
182     $dup_rdr = ($dad_rdr =~ s/^[<>]&//);
183     $dup_err = ($dad_err =~ s/^[<>]&//);
184
185     # force unqualified filehandles into caller's package
186     $dad_wtr = qualify $dad_wtr, $package unless fh_is_fd($dad_wtr);
187     $dad_rdr = qualify $dad_rdr, $package unless fh_is_fd($dad_rdr);
188     $dad_err = qualify $dad_err, $package unless fh_is_fd($dad_err);
189
190     my $kid_rdr = gensym;
191     my $kid_wtr = gensym;
192     my $kid_err = gensym;
193
194     xpipe $kid_rdr, $dad_wtr if !$dup_wtr;
195     xpipe $dad_rdr, $kid_wtr if !$dup_rdr;
196     xpipe $dad_err, $kid_err if !$dup_err && $dad_err ne $dad_rdr;
197
198     $kidpid = $do_spawn ? -1 : xfork;
199     if ($kidpid == 0) {         # Kid
200         # A tie in the parent should not be allowed to cause problems.
201         untie *STDIN;
202         untie *STDOUT;
203         # If she wants to dup the kid's stderr onto her stdout I need to
204         # save a copy of her stdout before I put something else there.
205         if ($dad_rdr ne $dad_err && $dup_err
206                 && xfileno($dad_err) == fileno(STDOUT)) {
207             my $tmp = gensym;
208             xopen($tmp, ">&$dad_err");
209             $dad_err = $tmp;
210         }
211
212         if ($dup_wtr) {
213             xopen \*STDIN,  "<&$dad_wtr" if fileno(STDIN) != xfileno($dad_wtr);
214         } else {
215             xclose $dad_wtr;
216             xopen \*STDIN,  "<&=" . fileno $kid_rdr;
217         }
218         if ($dup_rdr) {
219             xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != xfileno($dad_rdr);
220         } else {
221             xclose $dad_rdr;
222             xopen \*STDOUT, ">&=" . fileno $kid_wtr;
223         }
224         if ($dad_rdr ne $dad_err) {
225             if ($dup_err) {
226                 # I have to use a fileno here because in this one case
227                 # I'm doing a dup but the filehandle might be a reference
228                 # (from the special case above).
229                 xopen \*STDERR, ">&" . xfileno($dad_err)
230                     if fileno(STDERR) != xfileno($dad_err);
231             } else {
232                 xclose $dad_err;
233                 xopen \*STDERR, ">&=" . fileno $kid_err;
234             }
235         } else {
236             xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT);
237         }
238         if ($cmd[0] eq '-') {
239             croak "Arguments don't make sense when the command is '-'"
240               if @cmd > 1;
241             return 0;
242         }
243         local($")=(" ");
244         exec @cmd # XXX: wrong process to croak from
245             or croak "$Me: exec of @cmd failed";
246     } elsif ($do_spawn) {
247         # All the bookkeeping of coincidence between handles is
248         # handled in spawn_with_handles.
249
250         my @close;
251         if ($dup_wtr) {
252           $kid_rdr = \*{$dad_wtr};
253           push @close, $kid_rdr;
254         } else {
255           push @close, \*{$dad_wtr}, $kid_rdr;
256         }
257         if ($dup_rdr) {
258           $kid_wtr = \*{$dad_rdr};
259           push @close, $kid_wtr;
260         } else {
261           push @close, \*{$dad_rdr}, $kid_wtr;
262         }
263         if ($dad_rdr ne $dad_err) {
264             if ($dup_err) {
265               $kid_err = \*{$dad_err};
266               push @close, $kid_err;
267             } else {
268               push @close, \*{$dad_err}, $kid_err;
269             }
270         } else {
271           $kid_err = $kid_wtr;
272         }
273         require IO::Pipe;
274         $kidpid = eval {
275             spawn_with_handles( [ { mode => 'r',
276                                     open_as => $kid_rdr,
277                                     handle => \*STDIN },
278                                   { mode => 'w',
279                                     open_as => $kid_wtr,
280                                     handle => \*STDOUT },
281                                   { mode => 'w',
282                                     open_as => $kid_err,
283                                     handle => \*STDERR },
284                                 ], \@close, @cmd);
285         };
286         die "$Me: $@" if $@;
287     }
288
289     xclose $kid_rdr if !$dup_wtr;
290     xclose $kid_wtr if !$dup_rdr;
291     xclose $kid_err if !$dup_err && $dad_rdr ne $dad_err;
292     # If the write handle is a dup give it away entirely, close my copy
293     # of it.
294     xclose $dad_wtr if $dup_wtr;
295
296     select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
297     $kidpid;
298 }
299
300 sub open3 {
301     if (@_ < 4) {
302         local $" = ', ';
303         croak "open3(@_): not enough arguments";
304     }
305     return _open3 'open3', scalar caller, @_
306 }
307
308 sub spawn_with_handles {
309     my $fds = shift;            # Fields: handle, mode, open_as
310     my $close_in_child = shift;
311     my ($fd, $pid, @saved_fh, $saved, %saved, @errs);
312     require Fcntl;
313
314     foreach $fd (@$fds) {
315         $fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode});
316         $saved{fileno $fd->{handle}} = $fd->{tmp_copy};
317     }
318     foreach $fd (@$fds) {
319         bless $fd->{handle}, 'IO::Handle'
320             unless eval { $fd->{handle}->isa('IO::Handle') } ;
321         # If some of handles to redirect-to coincide with handles to
322         # redirect, we need to use saved variants:
323         $fd->{handle}->fdopen($saved{fileno $fd->{open_as}} || $fd->{open_as},
324                               $fd->{mode});
325     }
326     unless ($^O eq 'MSWin32') {
327         # Stderr may be redirected below, so we save the err text:
328         foreach $fd (@$close_in_child) {
329             fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!"
330                 unless $saved{fileno $fd}; # Do not close what we redirect!
331         }
332     }
333
334     unless (@errs) {
335         $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
336         push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!" if !$pid || $pid < 0;
337     }
338
339     foreach $fd (@$fds) {
340         $fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode});
341         $fd->{tmp_copy}->close or croak "Can't close: $!";
342     }
343     croak join "\n", @errs if @errs;
344     return $pid;
345 }
346
347 1; # so require is happy