Commit | Line | Data |
---|---|---|
a0d0e21e | 1 | package IPC::Open3; |
7e1af8bc | 2 | |
3 | use strict; | |
4 | no strict 'refs'; # because users pass me bareword filehandles | |
2675ae2b | 5 | our ($VERSION, @ISA, @EXPORT); |
7e1af8bc | 6 | |
a0d0e21e | 7 | require Exporter; |
7e1af8bc | 8 | |
a0d0e21e | 9 | use Carp; |
8b3e92c6 | 10 | use Symbol qw(gensym qualify); |
7e1af8bc | 11 | |
658152ad | 12 | $VERSION = '1.15'; |
7e1af8bc | 13 | @ISA = qw(Exporter); |
14 | @EXPORT = qw(open3); | |
a0d0e21e | 15 | |
f06db76b AD |
16 | =head1 NAME |
17 | ||
14333e50 | 18 | IPC::Open3 - open a process for reading, writing, and error handling using open3() |
f06db76b AD |
19 | |
20 | =head1 SYNOPSIS | |
21 | ||
3ce239a0 | 22 | $pid = open3(\*CHLD_IN, \*CHLD_OUT, \*CHLD_ERR, |
f06db76b AD |
23 | 'some cmd and args', 'optarg', ...); |
24 | ||
2675ae2b | 25 | my($wtr, $rdr, $err); |
92be7001 | 26 | use Symbol 'gensym'; $err = gensym; |
2675ae2b GS |
27 | $pid = open3($wtr, $rdr, $err, |
28 | 'some cmd and args', 'optarg', ...); | |
29 | ||
b2080196 | 30 | waitpid( $pid, 0 ); |
31 | my $child_exit_status = $? >> 8; | |
32 | ||
f06db76b AD |
33 | =head1 DESCRIPTION |
34 | ||
35 | Extremely similar to open2(), open3() spawns the given $cmd and | |
3ce239a0 BT |
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 | |
92be7001 SR |
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. | |
3ce239a0 BT |
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. | |
f06db76b | 48 | |
2675ae2b GS |
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 | |
8960aa87 | 51 | in the parameter slot so it can be overwritten in the caller, or |
2675ae2b | 52 | an exception will be raised. |
cb1a09d0 | 53 | |
036b4402 GS |
54 | The filehandles may also be integers, in which case they are understood |
55 | as file descriptors. | |
56 | ||
7e1af8bc | 57 | open3() returns the process ID of the child process. It doesn't return on |
2675ae2b | 58 | failure: it just raises an exception matching C</^open3:/>. However, |
eee4b3e7 | 59 | C<exec> failures in the child (such as no such file or permission denied), |
cccbbce9 PB |
60 | are just reported to CHLD_ERR under Windows and OS/2, as it is not possible |
61 | to trap them. | |
eee4b3e7 DM |
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. | |
f06db76b | 66 | |
a2a63531 AS |
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 | ||
8960aa87 | 72 | open3() does not wait for and reap the child process after it exits. |
227e8dd4 | 73 | Except for short programs where it's acceptable to let the operating system |
8960aa87 | 74 | take care of this, you need to do this yourself. This is normally as |
227e8dd4 GS |
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 | ||
2675ae2b GS |
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, | |
7e1af8bc | 89 | however, are quite apt to cause deadlock. |
90 | ||
91 | The big problem with this approach is that if you don't have control | |
7a2e2cd6 | 92 | over source code being run in the child process, you can't control |
7e1af8bc | 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 | ||
eee4b3e7 DM |
96 | =head1 See Also |
97 | ||
98 | =over 4 | |
99 | ||
100 | =item L<IPC::Open2> | |
101 | ||
181d2a7c | 102 | Like Open3 but without STDERR capture. |
eee4b3e7 DM |
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 | ||
2675ae2b GS |
111 | =head1 WARNING |
112 | ||
113 | The order of arguments differs from that of open2(). | |
114 | ||
7e1af8bc | 115 | =cut |
a0d0e21e LW |
116 | |
117 | # &open3: Marc Horowitz <marc@mit.edu> | |
118 | # derived mostly from &open2 by tom christiansen, <tchrist@convex.com> | |
4633a7c4 | 119 | # fixed for 5.001 by Ulrich Kunitz <kunitz@mai-koeln.com> |
f55ee38a | 120 | # ported to Win32 by Ron Schmidt, Merrill Lynch almost ended my career |
2675ae2b | 121 | # fixed for autovivving FHs, tchrist again |
6662521e | 122 | # allow fd numbers to be used, by Frank Tobin |
a2a63531 | 123 | # allow '-' as command (c.f. open "-|"), by Adam Spiers <perl@adamspiers.org> |
a0d0e21e | 124 | # |
a0d0e21e LW |
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 | |
7e1af8bc | 131 | # of child (or dies on failure). |
a0d0e21e LW |
132 | |
133 | ||
4633a7c4 | 134 | # if wtr begins with '<&', then wtr will be closed in the parent, and |
a0d0e21e LW |
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 | |
7e1af8bc | 147 | # a system call fails |
a0d0e21e | 148 | |
2675ae2b | 149 | our $Me = 'open3 (bug)'; # you should never see this, it's always localized |
a0d0e21e | 150 | |
7e1af8bc | 151 | # Fatal.pm needs to be fixed WRT prototypes. |
152 | ||
7e1af8bc | 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 | |
b7b1e41b | 158 | # disallows a bareword while compiling under strict subs. |
a0d0e21e | 159 | |
7e1af8bc | 160 | sub xopen { |
ea87ae30 NC |
161 | open $_[0], $_[1], @_[2..$#_] and return; |
162 | local $" = ', '; | |
163 | carp "$Me: open(@_) failed: $!"; | |
7e1af8bc | 164 | } |
165 | ||
166 | sub xclose { | |
8700fd38 SH |
167 | $_[0] =~ /\A=?(\d+)\z/ |
168 | ? do { my $fh; open($fh, $_[1] . '&=' . $1) and close($fh); } | |
169 | : close $_[0] | |
f6f8630d | 170 | or croak "$Me: close($_[0]) failed: $!"; |
7e1af8bc | 171 | } |
172 | ||
036b4402 GS |
173 | sub xfileno { |
174 | return $1 if $_[0] =~ /\A=?(\d+)\z/; # deal with fh just being an fd | |
175 | return fileno $_[0]; | |
6662521e GS |
176 | } |
177 | ||
f598f6de NC |
178 | use constant FORCE_DEBUG_SPAWN => 0; |
179 | use constant DO_SPAWN => $^O eq 'os2' || $^O eq 'MSWin32' || FORCE_DEBUG_SPAWN; | |
a24d8dfd | 180 | |
7e1af8bc | 181 | sub _open3 { |
182 | local $Me = shift; | |
eee4b3e7 | 183 | |
2675ae2b GS |
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 | ||
ce0d59fd FC |
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; | |
2675ae2b | 192 | unless (eval { |
cf0c26e1 NC |
193 | $_[0] = gensym unless defined $_[0] && length $_[0]; |
194 | $_[1] = gensym unless defined $_[1] && length $_[1]; | |
8960aa87 | 195 | 1; }) |
2675ae2b GS |
196 | { |
197 | # must strip crud for croak to add back, or looks ugly | |
198 | $@ =~ s/(?<=value attempted) at .*//s; | |
199 | croak "$Me: $@"; | |
8960aa87 | 200 | } |
2675ae2b | 201 | |
cae0d269 NC |
202 | my @handles = ({ mode => '<', handle => \*STDIN }, |
203 | { mode => '>', handle => \*STDOUT }, | |
204 | { mode => '>', handle => \*STDERR }, | |
b74a613e NC |
205 | ); |
206 | ||
9340a1e0 NC |
207 | foreach (@handles) { |
208 | $_->{parent} = shift; | |
b38d735f | 209 | $_->{open_as} = gensym; |
9340a1e0 NC |
210 | } |
211 | ||
9340a1e0 | 212 | if (@_ > 1 and $_[0] eq '-') { |
cf0c26e1 NC |
213 | croak "Arguments don't make sense when the command is '-'" |
214 | } | |
215 | ||
9340a1e0 | 216 | $handles[2]{parent} ||= $handles[1]{parent}; |
f2412f89 | 217 | $handles[2]{dup_of_out} = $handles[1]{parent} eq $handles[2]{parent}; |
a0d0e21e | 218 | |
0c12e47a NC |
219 | my $package; |
220 | foreach (@handles) { | |
221 | $_->{dup} = ($_->{parent} =~ s/^[<>]&//); | |
a0d0e21e | 222 | |
0c12e47a NC |
223 | if ($_->{parent} !~ /\A=?(\d+)\z/) { |
224 | # force unqualified filehandles into caller's package | |
225 | $package //= caller 1; | |
226 | $_->{parent} = qualify $_->{parent}, $package; | |
227 | } | |
7e1af8bc | 228 | |
0c12e47a NC |
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 | } | |
7e1af8bc | 236 | |
38e62fca | 237 | my $kidpid; |
8960aa87 EB |
238 | if (!DO_SPAWN) { |
239 | # Used to communicate exec failures. | |
240 | xpipe my $stat_r, my $stat_w; | |
241 | ||
258a5898 NC |
242 | $kidpid = fork; |
243 | croak "$Me: fork failed: $!" unless defined $kidpid; | |
8960aa87 EB |
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; | |
258a5898 NC |
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: $!"; | |
8960aa87 EB |
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. | |
f2412f89 | 259 | if (!$handles[2]{dup_of_out} && $handles[2]{dup} |
9340a1e0 | 260 | && xfileno($handles[2]{parent}) == fileno \*STDOUT) { |
8960aa87 | 261 | my $tmp = gensym; |
9340a1e0 NC |
262 | xopen($tmp, '>&', $handles[2]{parent}); |
263 | $handles[2]{parent} = $tmp; | |
8960aa87 EB |
264 | } |
265 | ||
afebf859 NC |
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}); | |
8960aa87 | 273 | } else { |
8700fd38 | 274 | xclose $_->{parent}, $_->{mode}; |
afebf859 NC |
275 | xopen $_->{handle}, $_->{mode} . '&=', |
276 | fileno $_->{open_as}; | |
8960aa87 | 277 | } |
8960aa87 | 278 | } |
f8b0429f | 279 | return 1 if ($_[0] eq '-'); |
9340a1e0 | 280 | exec @_ or do { |
8960aa87 | 281 | local($")=(" "); |
9340a1e0 | 282 | croak "$Me: exec of @_ failed"; |
8960aa87 | 283 | }; |
f8b0429f SF |
284 | } and do { |
285 | close $stat_w; | |
286 | return 0; | |
287 | }; | |
8960aa87 EB |
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; | |
a0d0e21e | 294 | |
8960aa87 EB |
295 | eval { require POSIX; POSIX::_exit(255); }; |
296 | exit 255; | |
a0d0e21e | 297 | } |
8960aa87 EB |
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); | |
cccbbce9 | 305 | waitpid $kidpid, 0; # Reap child which should have exited |
8960aa87 EB |
306 | if ($err) { |
307 | utf8::decode $err if $] >= 5.008; | |
308 | } else { | |
309 | $err = "$Me: " . ($! = $bang); | |
310 | } | |
311 | $! = $bang; | |
312 | die($err); | |
a0d0e21e | 313 | } |
a0d0e21e | 314 | } |
8960aa87 EB |
315 | } |
316 | else { # DO_SPAWN | |
a24d8dfd IZ |
317 | # All the bookkeeping of coincidence between handles is |
318 | # handled in spawn_with_handles. | |
319 | ||
320 | my @close; | |
a500d274 NC |
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}; | |
a24d8dfd | 329 | } else { |
a500d274 | 330 | push @close, \*{$_->{parent}}, $_->{open_as}; |
a24d8dfd | 331 | } |
a24d8dfd IZ |
332 | } |
333 | require IO::Pipe; | |
334 | $kidpid = eval { | |
9340a1e0 | 335 | spawn_with_handles(\@handles, \@close, @_); |
a24d8dfd | 336 | }; |
ad973f30 | 337 | die "$Me: $@" if $@; |
a0d0e21e LW |
338 | } |
339 | ||
0c12e47a NC |
340 | foreach (@handles) { |
341 | next if $_->{dup} or $_->{dup_of_out}; | |
8700fd38 | 342 | xclose $_->{open_as}, $_->{mode}; |
0c12e47a NC |
343 | } |
344 | ||
7e1af8bc | 345 | # If the write handle is a dup give it away entirely, close my copy |
346 | # of it. | |
8700fd38 | 347 | xclose $handles[0]{parent}, $handles[0]{mode} if $handles[0]{dup}; |
a0d0e21e | 348 | |
9340a1e0 | 349 | select((select($handles[0]{parent}), $| = 1)[0]); # unbuffer pipe |
a0d0e21e LW |
350 | $kidpid; |
351 | } | |
7e1af8bc | 352 | |
353 | sub open3 { | |
a24d8dfd IZ |
354 | if (@_ < 4) { |
355 | local $" = ', '; | |
356 | croak "open3(@_): not enough arguments"; | |
357 | } | |
0689e260 | 358 | return _open3 'open3', @_ |
7e1af8bc | 359 | } |
a0d0e21e | 360 | |
a24d8dfd IZ |
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); | |
a24d8dfd IZ |
365 | |
366 | foreach $fd (@$fds) { | |
367 | $fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode}); | |
031f91ce | 368 | $saved{fileno $fd->{handle}} = $fd->{tmp_copy} if $fd->{tmp_copy}; |
a24d8dfd IZ |
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: | |
b38d735f NC |
375 | $fd->{handle}->fdopen(defined fileno $fd->{open_as} |
376 | ? $saved{fileno $fd->{open_as}} || $fd->{open_as} | |
377 | : $fd->{open_as}, | |
a24d8dfd IZ |
378 | $fd->{mode}); |
379 | } | |
f55ee38a | 380 | unless ($^O eq 'MSWin32') { |
cae0d269 | 381 | require Fcntl; |
f55ee38a GS |
382 | # Stderr may be redirected below, so we save the err text: |
383 | foreach $fd (@$close_in_child) { | |
f598f6de | 384 | next unless fileno $fd; |
f55ee38a GS |
385 | fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!" |
386 | unless $saved{fileno $fd}; # Do not close what we redirect! | |
387 | } | |
a24d8dfd IZ |
388 | } |
389 | ||
390 | unless (@errs) { | |
f598f6de NC |
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 | } | |
a24d8dfd IZ |
411 | push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!" if !$pid || $pid < 0; |
412 | } | |
413 | ||
031f91ce NC |
414 | # Do this in reverse, so that STDERR is restored first: |
415 | foreach $fd (reverse @$fds) { | |
a24d8dfd | 416 | $fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode}); |
031f91ce NC |
417 | } |
418 | foreach (values %saved) { | |
419 | $_->close or croak "Can't close: $!"; | |
a24d8dfd IZ |
420 | } |
421 | croak join "\n", @errs if @errs; | |
422 | return $pid; | |
423 | } | |
424 | ||
425 | 1; # so require is happy |