This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
179313b0b66d023fa2a1b3e9f1a69f2182374e7f
[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.11';
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 # usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...);
125 #
126 # spawn the given $cmd and connect rdr for
127 # reading, wtr for writing, and err for errors.
128 # if err is '', or the same as rdr, then stdout and
129 # stderr of the child are on the same fh.  returns pid
130 # of child (or dies on failure).
131
132
133 # if wtr begins with '<&', then wtr will be closed in the parent, and
134 # the child will read from it directly.  if rdr or err begins with
135 # '>&', then the child will send output directly to that fd.  In both
136 # cases, there will be a dup() instead of a pipe() made.
137
138
139 # WARNING: this is dangerous, as you may block forever
140 # unless you are very careful.
141 #
142 # $wtr is left unbuffered.
143 #
144 # abort program if
145 #   rdr or wtr are null
146 #   a system call fails
147
148 our $Me = 'open3 (bug)';        # you should never see this, it's always localized
149
150 # Fatal.pm needs to be fixed WRT prototypes.
151
152 sub xpipe {
153     pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!";
154 }
155
156 # I tried using a * prototype character for the filehandle but it still
157 # disallows a bareword while compiling under strict subs.
158
159 sub xopen {
160     open $_[0], $_[1], @_[2..$#_] and return;
161     local $" = ', ';
162     carp "$Me: open(@_) failed: $!";
163 }
164
165 sub xclose {
166     $_[0] =~ /\A=?(\d+)\z/ ? eval { require POSIX; POSIX::close($1); } : close $_[0]
167         or croak "$Me: close($_[0]) failed: $!";
168 }
169
170 sub xfileno {
171     return $1 if $_[0] =~ /\A=?(\d+)\z/;  # deal with fh just being an fd
172     return fileno $_[0];
173 }
174
175 use constant FORCE_DEBUG_SPAWN => 0;
176 use constant DO_SPAWN => $^O eq 'os2' || $^O eq 'MSWin32' || FORCE_DEBUG_SPAWN;
177
178 sub _open3 {
179     local $Me = shift;
180
181     # simulate autovivification of filehandles because
182     # it's too ugly to use @_ throughout to make perl do it for us
183     # tchrist 5-Mar-00
184
185     unless (eval  {
186         $_[0] = gensym unless defined $_[0] && length $_[0];
187         $_[1] = gensym unless defined $_[1] && length $_[1];
188         1; })
189     {
190         # must strip crud for croak to add back, or looks ugly
191         $@ =~ s/(?<=value attempted) at .*//s;
192         croak "$Me: $@";
193     }
194
195     my @handles = ({ mode => '<', handle => \*STDIN },
196                    { mode => '>', handle => \*STDOUT },
197                    { mode => '>', handle => \*STDERR },
198                   );
199
200     foreach (@handles) {
201         $_->{parent} = shift;
202         $_->{open_as} = gensym;
203     }
204
205     if (@_ > 1 and $_[0] eq '-') {
206         croak "Arguments don't make sense when the command is '-'"
207     }
208
209     $handles[2]{parent} ||= $handles[1]{parent};
210     $handles[2]{dup_of_out} = $handles[1]{parent} eq $handles[2]{parent};
211
212     my $package;
213     foreach (@handles) {
214         $_->{dup} = ($_->{parent} =~ s/^[<>]&//);
215
216         if ($_->{parent} !~ /\A=?(\d+)\z/) {
217             # force unqualified filehandles into caller's package
218             $package //= caller 1;
219             $_->{parent} = qualify $_->{parent}, $package;
220         }
221
222         next if $_->{dup} or $_->{dup_of_out};
223         if ($_->{mode} eq '<') {
224             xpipe $_->{open_as}, $_->{parent};
225         } else {
226             xpipe $_->{parent}, $_->{open_as};
227         }
228     }
229
230     my $kidpid;
231     if (!DO_SPAWN) {
232         # Used to communicate exec failures.
233         xpipe my $stat_r, my $stat_w;
234
235         $kidpid = fork;
236         croak "$Me: fork failed: $!" unless defined $kidpid;
237         if ($kidpid == 0) {  # Kid
238             eval {
239                 # A tie in the parent should not be allowed to cause problems.
240                 untie *STDIN;
241                 untie *STDOUT;
242
243                 close $stat_r;
244                 require Fcntl;
245                 my $flags = fcntl $stat_w, &Fcntl::F_GETFD, 0;
246                 croak "$Me: fcntl failed: $!" unless $flags;
247                 fcntl $stat_w, &Fcntl::F_SETFD, $flags|&Fcntl::FD_CLOEXEC
248                     or croak "$Me: fcntl failed: $!";
249
250                 # If she wants to dup the kid's stderr onto her stdout I need to
251                 # save a copy of her stdout before I put something else there.
252                 if (!$handles[2]{dup_of_out} && $handles[2]{dup}
253                         && xfileno($handles[2]{parent}) == fileno \*STDOUT) {
254                     my $tmp = gensym;
255                     xopen($tmp, '>&', $handles[2]{parent});
256                     $handles[2]{parent} = $tmp;
257                 }
258
259                 foreach (@handles) {
260                     if ($_->{dup_of_out}) {
261                         xopen \*STDERR, ">&STDOUT"
262                             if defined fileno STDERR && fileno STDERR != fileno STDOUT;
263                     } elsif ($_->{dup}) {
264                         xopen $_->{handle}, $_->{mode} . '&', $_->{parent}
265                             if fileno $_->{handle} != xfileno($_->{parent});
266                     } else {
267                         xclose $_->{parent};
268                         xopen $_->{handle}, $_->{mode} . '&=',
269                             fileno $_->{open_as};
270                     }
271                 }
272                 return 1 if ($_[0] eq '-');
273                 exec @_ or do {
274                     local($")=(" ");
275                     croak "$Me: exec of @_ failed";
276                 };
277             } and do {
278                 close $stat_w;
279                 return 0;
280             };
281
282             my $bang = 0+$!;
283             my $err = $@;
284             utf8::encode $err if $] >= 5.008;
285             print $stat_w pack('IIa*', $bang, length($err), $err);
286             close $stat_w;
287
288             eval { require POSIX; POSIX::_exit(255); };
289             exit 255;
290         }
291         else {  # Parent
292             close $stat_w;
293             my $to_read = length(pack('I', 0)) * 2;
294             my $bytes_read = read($stat_r, my $buf = '', $to_read);
295             if ($bytes_read) {
296                 (my $bang, $to_read) = unpack('II', $buf);
297                 read($stat_r, my $err = '', $to_read);
298                 if ($err) {
299                     utf8::decode $err if $] >= 5.008;
300                 } else {
301                     $err = "$Me: " . ($! = $bang);
302                 }
303                 $! = $bang;
304                 die($err);
305             }
306         }
307     }
308     else {  # DO_SPAWN
309         # All the bookkeeping of coincidence between handles is
310         # handled in spawn_with_handles.
311
312         my @close;
313
314         foreach (@handles) {
315             if ($_->{dup_of_out}) {
316                 $_->{open_as} = $handles[1]{open_as};
317             } elsif ($_->{dup}) {
318                 $_->{open_as} = $_->{parent} =~ /\A[0-9]+\z/
319                     ? $_->{parent} : \*{$_->{parent}};
320                 push @close, $_->{open_as};
321             } else {
322                 push @close, \*{$_->{parent}}, $_->{open_as};
323             }
324         }
325         require IO::Pipe;
326         $kidpid = eval {
327             spawn_with_handles(\@handles, \@close, @_);
328         };
329         die "$Me: $@" if $@;
330     }
331
332     foreach (@handles) {
333         next if $_->{dup} or $_->{dup_of_out};
334         xclose $_->{open_as};
335     }
336
337     # If the write handle is a dup give it away entirely, close my copy
338     # of it.
339     xclose $handles[0]{parent} if $handles[0]{dup};
340
341     select((select($handles[0]{parent}), $| = 1)[0]); # unbuffer pipe
342     $kidpid;
343 }
344
345 sub open3 {
346     if (@_ < 4) {
347         local $" = ', ';
348         croak "open3(@_): not enough arguments";
349     }
350     return _open3 'open3', @_
351 }
352
353 sub spawn_with_handles {
354     my $fds = shift;            # Fields: handle, mode, open_as
355     my $close_in_child = shift;
356     my ($fd, $pid, @saved_fh, $saved, %saved, @errs);
357
358     foreach $fd (@$fds) {
359         $fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode});
360         $saved{fileno $fd->{handle}} = $fd->{tmp_copy} if $fd->{tmp_copy};
361     }
362     foreach $fd (@$fds) {
363         bless $fd->{handle}, 'IO::Handle'
364             unless eval { $fd->{handle}->isa('IO::Handle') } ;
365         # If some of handles to redirect-to coincide with handles to
366         # redirect, we need to use saved variants:
367         $fd->{handle}->fdopen(defined fileno $fd->{open_as}
368                               ? $saved{fileno $fd->{open_as}} || $fd->{open_as}
369                               : $fd->{open_as},
370                               $fd->{mode});
371     }
372     unless ($^O eq 'MSWin32') {
373         require Fcntl;
374         # Stderr may be redirected below, so we save the err text:
375         foreach $fd (@$close_in_child) {
376             next unless fileno $fd;
377             fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!"
378                 unless $saved{fileno $fd}; # Do not close what we redirect!
379         }
380     }
381
382     unless (@errs) {
383         if (FORCE_DEBUG_SPAWN) {
384             pipe my $r, my $w or die "Pipe failed: $!";
385             $pid = fork;
386             die "Fork failed: $!" unless defined $pid;
387             if (!$pid) {
388                 { no warnings; exec @_ }
389                 print $w 0 + $!;
390                 close $w;
391                 require POSIX;
392                 POSIX::_exit(255);
393             }
394             close $w;
395             my $bad = <$r>;
396             if (defined $bad) {
397                 $! = $bad;
398                 undef $pid;
399             }
400         } else {
401             $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
402         }
403         push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!" if !$pid || $pid < 0;
404     }
405
406     # Do this in reverse, so that STDERR is restored first:
407     foreach $fd (reverse @$fds) {
408         $fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode});
409     }
410     foreach (values %saved) {
411         $_->close or croak "Can't close: $!";
412     }
413     croak join "\n", @errs if @errs;
414     return $pid;
415 }
416
417 1; # so require is happy