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