This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Increase $IPC::Open3::VERSION to 1.16
[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.16';
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     # Historically, open3(undef...) has silently worked, so keep
189     # it working.
190     splice @_, 0, 1, undef if \$_[0] == \undef;
191     splice @_, 1, 1, undef if \$_[1] == \undef;
192     unless (eval  {
193         $_[0] = gensym unless defined $_[0] && length $_[0];
194         $_[1] = gensym unless defined $_[1] && length $_[1];
195         1; })
196     {
197         # must strip crud for croak to add back, or looks ugly
198         $@ =~ s/(?<=value attempted) at .*//s;
199         croak "$Me: $@";
200     }
201
202     my @handles = ({ mode => '<', handle => \*STDIN },
203                    { mode => '>', handle => \*STDOUT },
204                    { mode => '>', handle => \*STDERR },
205                   );
206
207     foreach (@handles) {
208         $_->{parent} = shift;
209         $_->{open_as} = gensym;
210     }
211
212     if (@_ > 1 and $_[0] eq '-') {
213         croak "Arguments don't make sense when the command is '-'"
214     }
215
216     $handles[2]{parent} ||= $handles[1]{parent};
217     $handles[2]{dup_of_out} = $handles[1]{parent} eq $handles[2]{parent};
218
219     my $package;
220     foreach (@handles) {
221         $_->{dup} = ($_->{parent} =~ s/^[<>]&//);
222
223         if ($_->{parent} !~ /\A=?(\d+)\z/) {
224             # force unqualified filehandles into caller's package
225             $package //= caller 1;
226             $_->{parent} = qualify $_->{parent}, $package;
227         }
228
229         next if $_->{dup} or $_->{dup_of_out};
230         if ($_->{mode} eq '<') {
231             xpipe $_->{open_as}, $_->{parent};
232         } else {
233             xpipe $_->{parent}, $_->{open_as};
234         }
235     }
236
237     my $kidpid;
238     if (!DO_SPAWN) {
239         # Used to communicate exec failures.
240         xpipe my $stat_r, my $stat_w;
241
242         $kidpid = fork;
243         croak "$Me: fork failed: $!" unless defined $kidpid;
244         if ($kidpid == 0) {  # Kid
245             eval {
246                 # A tie in the parent should not be allowed to cause problems.
247                 untie *STDIN;
248                 untie *STDOUT;
249
250                 close $stat_r;
251                 require Fcntl;
252                 my $flags = fcntl $stat_w, &Fcntl::F_GETFD, 0;
253                 croak "$Me: fcntl failed: $!" unless $flags;
254                 fcntl $stat_w, &Fcntl::F_SETFD, $flags|&Fcntl::FD_CLOEXEC
255                     or croak "$Me: fcntl failed: $!";
256
257                 # If she wants to dup the kid's stderr onto her stdout I need to
258                 # save a copy of her stdout before I put something else there.
259                 if (!$handles[2]{dup_of_out} && $handles[2]{dup}
260                         && xfileno($handles[2]{parent}) == fileno \*STDOUT) {
261                     my $tmp = gensym;
262                     xopen($tmp, '>&', $handles[2]{parent});
263                     $handles[2]{parent} = $tmp;
264                 }
265
266                 foreach (@handles) {
267                     if ($_->{dup_of_out}) {
268                         xopen \*STDERR, ">&STDOUT"
269                             if defined fileno STDERR && fileno STDERR != fileno STDOUT;
270                     } elsif ($_->{dup}) {
271                         xopen $_->{handle}, $_->{mode} . '&', $_->{parent}
272                             if fileno $_->{handle} != xfileno($_->{parent});
273                     } else {
274                         xclose $_->{parent}, $_->{mode};
275                         xopen $_->{handle}, $_->{mode} . '&=',
276                             fileno $_->{open_as};
277                     }
278                 }
279                 return 1 if ($_[0] eq '-');
280                 exec @_ or do {
281                     local($")=(" ");
282                     croak "$Me: exec of @_ failed";
283                 };
284             } and do {
285                 close $stat_w;
286                 return 0;
287             };
288
289             my $bang = 0+$!;
290             my $err = $@;
291             utf8::encode $err if $] >= 5.008;
292             print $stat_w pack('IIa*', $bang, length($err), $err);
293             close $stat_w;
294
295             eval { require POSIX; POSIX::_exit(255); };
296             exit 255;
297         }
298         else {  # Parent
299             close $stat_w;
300             my $to_read = length(pack('I', 0)) * 2;
301             my $bytes_read = read($stat_r, my $buf = '', $to_read);
302             if ($bytes_read) {
303                 (my $bang, $to_read) = unpack('II', $buf);
304                 read($stat_r, my $err = '', $to_read);
305                 waitpid $kidpid, 0; # Reap child which should have exited
306                 if ($err) {
307                     utf8::decode $err if $] >= 5.008;
308                 } else {
309                     $err = "$Me: " . ($! = $bang);
310                 }
311                 $! = $bang;
312                 die($err);
313             }
314         }
315     }
316     else {  # DO_SPAWN
317         # All the bookkeeping of coincidence between handles is
318         # handled in spawn_with_handles.
319
320         my @close;
321
322         foreach (@handles) {
323             if ($_->{dup_of_out}) {
324                 $_->{open_as} = $handles[1]{open_as};
325             } elsif ($_->{dup}) {
326                 $_->{open_as} = $_->{parent} =~ /\A[0-9]+\z/
327                     ? $_->{parent} : \*{$_->{parent}};
328                 push @close, $_->{open_as};
329             } else {
330                 push @close, \*{$_->{parent}}, $_->{open_as};
331             }
332         }
333         require IO::Pipe;
334         $kidpid = eval {
335             spawn_with_handles(\@handles, \@close, @_);
336         };
337         die "$Me: $@" if $@;
338     }
339
340     foreach (@handles) {
341         next if $_->{dup} or $_->{dup_of_out};
342         xclose $_->{open_as}, $_->{mode};
343     }
344
345     # If the write handle is a dup give it away entirely, close my copy
346     # of it.
347     xclose $handles[0]{parent}, $handles[0]{mode} if $handles[0]{dup};
348
349     select((select($handles[0]{parent}), $| = 1)[0]); # unbuffer pipe
350     $kidpid;
351 }
352
353 sub open3 {
354     if (@_ < 4) {
355         local $" = ', ';
356         croak "open3(@_): not enough arguments";
357     }
358     return _open3 'open3', @_
359 }
360
361 sub spawn_with_handles {
362     my $fds = shift;            # Fields: handle, mode, open_as
363     my $close_in_child = shift;
364     my ($fd, $pid, @saved_fh, $saved, %saved, @errs);
365
366     foreach $fd (@$fds) {
367         $fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode});
368         $saved{fileno $fd->{handle}} = $fd->{tmp_copy} if $fd->{tmp_copy};
369     }
370     foreach $fd (@$fds) {
371         bless $fd->{handle}, 'IO::Handle'
372             unless eval { $fd->{handle}->isa('IO::Handle') } ;
373         # If some of handles to redirect-to coincide with handles to
374         # redirect, we need to use saved variants:
375         $fd->{handle}->fdopen(defined fileno $fd->{open_as}
376                               ? $saved{fileno $fd->{open_as}} || $fd->{open_as}
377                               : $fd->{open_as},
378                               $fd->{mode});
379     }
380     unless ($^O eq 'MSWin32') {
381         require Fcntl;
382         # Stderr may be redirected below, so we save the err text:
383         foreach $fd (@$close_in_child) {
384             next unless fileno $fd;
385             fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!"
386                 unless $saved{fileno $fd}; # Do not close what we redirect!
387         }
388     }
389
390     unless (@errs) {
391         if (FORCE_DEBUG_SPAWN) {
392             pipe my $r, my $w or die "Pipe failed: $!";
393             $pid = fork;
394             die "Fork failed: $!" unless defined $pid;
395             if (!$pid) {
396                 { no warnings; exec @_ }
397                 print $w 0 + $!;
398                 close $w;
399                 require POSIX;
400                 POSIX::_exit(255);
401             }
402             close $w;
403             my $bad = <$r>;
404             if (defined $bad) {
405                 $! = $bad;
406                 undef $pid;
407             }
408         } else {
409             $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
410         }
411         push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!" if !$pid || $pid < 0;
412     }
413
414     # Do this in reverse, so that STDERR is restored first:
415     foreach $fd (reverse @$fds) {
416         $fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode});
417     }
418     foreach (values %saved) {
419         $_->close or croak "Can't close: $!";
420     }
421     croak join "\n", @errs if @errs;
422     return $pid;
423 }
424
425 1; # so require is happy