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