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