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