1package IPC::Open3;
2
3use strict;
4no strict 'refs'; # because users pass me bareword filehandles
5our ($VERSION, @ISA, @EXPORT);
6
7require Exporter;
8
9use Carp;
10use Symbol qw(gensym qualify);
11
12$VERSION	= '1.20';
13@ISA		= qw(Exporter);
14@EXPORT		= qw(open3);
15
16=head1 NAME
17
18IPC::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
35Extremely similar to open2(), open3() spawns the given $cmd and
36connects CHLD_OUT for reading from the child, CHLD_IN for writing to
37the child, and CHLD_ERR for errors.  If CHLD_ERR is false, or the
38same file descriptor as CHLD_OUT, then STDOUT and STDERR of the child
39are on the same filehandle (this means that an autovivified lexical
40cannot be used for the STDERR filehandle, see SYNOPSIS).  The CHLD_IN
41will have autoflush turned on.
42
43If CHLD_IN begins with C<< <& >>, then CHLD_IN will be closed in the
44parent, and the child will read from it directly.  If CHLD_OUT or
45CHLD_ERR begins with C<< >& >>, then the child will send output
46directly to that filehandle.  In both cases, there will be a dup(2)
47instead of a pipe(2) made.
48
49If either reader or writer is the null string, this will be replaced
50by an autogenerated filehandle.  If so, you must pass a valid lvalue
51in the parameter slot so it can be overwritten in the caller, or
52an exception will be raised.
53
54The filehandles may also be integers, in which case they are understood
55as file descriptors.
56
57open3() returns the process ID of the child process.  It doesn't return on
58failure: it just raises an exception matching C</^open3:/>.  However,
59C<exec> failures in the child (such as no such file or permission denied),
60are just reported to CHLD_ERR under Windows and OS/2, as it is not possible
61to trap them.
62
63If the child process dies for any reason, the next write to CHLD_IN is
64likely to generate a SIGPIPE in the parent, which is fatal by default.
65So you may wish to handle this signal.
66
67Note if you specify C<-> as the command, in an analogous fashion to
68C<open(FOO, "-|")> the child process will just be the forked Perl
69process rather than an external command.  This feature isn't yet
70supported on Win32 platforms.
71
72open3() does not wait for and reap the child process after it exits.
73Except for short programs where it's acceptable to let the operating system
74take care of this, you need to do this yourself.  This is normally as
75simple as calling C<waitpid $pid, 0> when you're done with the process.
76Failing to do this can result in an accumulation of defunct or "zombie"
77processes.  See L<perlfunc/waitpid> for more information.
78
79If you try to read from the child's stdout writer and their stderr
80writer, you'll have problems with blocking, which means you'll want
81to use select() or the IO::Select, which means you'd best use
82sysread() instead of readline() for normal stuff.
83
84This is very dangerous, as you may block forever.  It assumes it's
85going to talk to something like B<bc>, both writing to it and reading
86from it.  This is presumably safe because you "know" that commands
87like B<bc> will read a line at a time and output a line at a time.
88Programs like B<sort> that read their entire input stream first,
89however, are quite apt to cause deadlock.
90
91The big problem with this approach is that if you don't have control
92over source code being run in the child process, you can't control
93what it does with pipe buffering.  Thus you can't just open a pipe to
94C<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
102Like Open3 but without STDERR capture.
103
104=item L<IPC::Run>
105
106This is a CPAN module that has better error handling and more facilities
107than Open3.
108
109=back
110
111=head1 WARNING
112
113The 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
149our $Me = 'open3 (bug)';	# you should never see this, it's always localized
150
151# Fatal.pm needs to be fixed WRT prototypes.
152
153sub 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
160sub xopen {
161    open $_[0], $_[1], @_[2..$#_] and return;
162    local $" = ', ';
163    carp "$Me: open(@_) failed: $!";
164}
165
166sub 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
173sub xfileno {
174    return $1 if $_[0] =~ /\A=?(\d+)\z/;  # deal with fh just being an fd
175    return fileno $_[0];
176}
177
178use constant FORCE_DEBUG_SPAWN => 0;
179use constant DO_SPAWN => $^O eq 'os2' || $^O eq 'MSWin32' || FORCE_DEBUG_SPAWN;
180
181sub _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		untie *STDERR;
250
251		close $stat_r;
252		require Fcntl;
253		my $flags = fcntl $stat_w, &Fcntl::F_GETFD, 0;
254		croak "$Me: fcntl failed: $!" unless $flags;
255		fcntl $stat_w, &Fcntl::F_SETFD, $flags|&Fcntl::FD_CLOEXEC
256		    or croak "$Me: fcntl failed: $!";
257
258		# If she wants to dup the kid's stderr onto her stdout I need to
259		# save a copy of her stdout before I put something else there.
260		if (!$handles[2]{dup_of_out} && $handles[2]{dup}
261			&& xfileno($handles[2]{parent}) == fileno \*STDOUT) {
262		    my $tmp = gensym;
263		    xopen($tmp, '>&', $handles[2]{parent});
264		    $handles[2]{parent} = $tmp;
265		}
266
267		foreach (@handles) {
268		    if ($_->{dup_of_out}) {
269			xopen \*STDERR, ">&STDOUT"
270			    if defined fileno STDERR && fileno STDERR != fileno STDOUT;
271		    } elsif ($_->{dup}) {
272			xopen $_->{handle}, $_->{mode} . '&', $_->{parent}
273			    if fileno $_->{handle} != xfileno($_->{parent});
274		    } else {
275			xclose $_->{parent}, $_->{mode};
276			xopen $_->{handle}, $_->{mode} . '&=',
277			    fileno $_->{open_as};
278		    }
279		}
280		return 1 if ($_[0] eq '-');
281		exec @_ or do {
282		    local($")=(" ");
283		    croak "$Me: exec of @_ failed: $!";
284		};
285	    } and do {
286                close $stat_w;
287                return 0;
288            };
289
290	    my $bang = 0+$!;
291	    my $err = $@;
292	    utf8::encode $err if $] >= 5.008;
293	    print $stat_w pack('IIa*', $bang, length($err), $err);
294	    close $stat_w;
295
296	    eval { require POSIX; POSIX::_exit(255); };
297	    exit 255;
298	}
299	else {  # Parent
300	    close $stat_w;
301	    my $to_read = length(pack('I', 0)) * 2;
302	    my $bytes_read = read($stat_r, my $buf = '', $to_read);
303	    if ($bytes_read) {
304		(my $bang, $to_read) = unpack('II', $buf);
305		read($stat_r, my $err = '', $to_read);
306		waitpid $kidpid, 0; # Reap child which should have exited
307		if ($err) {
308		    utf8::decode $err if $] >= 5.008;
309		} else {
310		    $err = "$Me: " . ($! = $bang);
311		}
312		$! = $bang;
313		die($err);
314	    }
315	}
316    }
317    else {  # DO_SPAWN
318	# All the bookkeeping of coincidence between handles is
319	# handled in spawn_with_handles.
320
321	my @close;
322
323	foreach (@handles) {
324	    if ($_->{dup_of_out}) {
325		$_->{open_as} = $handles[1]{open_as};
326	    } elsif ($_->{dup}) {
327		$_->{open_as} = $_->{parent} =~ /\A[0-9]+\z/
328		    ? $_->{parent} : \*{$_->{parent}};
329		push @close, $_->{open_as};
330	    } else {
331		push @close, \*{$_->{parent}}, $_->{open_as};
332	    }
333	}
334	require IO::Pipe;
335	$kidpid = eval {
336	    spawn_with_handles(\@handles, \@close, @_);
337	};
338	die "$Me: $@" if $@;
339    }
340
341    foreach (@handles) {
342	next if $_->{dup} or $_->{dup_of_out};
343	xclose $_->{open_as}, $_->{mode};
344    }
345
346    # If the write handle is a dup give it away entirely, close my copy
347    # of it.
348    xclose $handles[0]{parent}, $handles[0]{mode} if $handles[0]{dup};
349
350    select((select($handles[0]{parent}), $| = 1)[0]); # unbuffer pipe
351    $kidpid;
352}
353
354sub open3 {
355    if (@_ < 4) {
356	local $" = ', ';
357	croak "open3(@_): not enough arguments";
358    }
359    return _open3 'open3', @_
360}
361
362sub spawn_with_handles {
363    my $fds = shift;		# Fields: handle, mode, open_as
364    my $close_in_child = shift;
365    my ($fd, %saved, @errs);
366
367    foreach $fd (@$fds) {
368	$fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode});
369	$saved{fileno $fd->{handle}} = $fd->{tmp_copy} if $fd->{tmp_copy};
370    }
371    foreach $fd (@$fds) {
372	bless $fd->{handle}, 'IO::Handle'
373	    unless eval { $fd->{handle}->isa('IO::Handle') } ;
374	# If some of handles to redirect-to coincide with handles to
375	# redirect, we need to use saved variants:
376    my $open_as = $fd->{open_as};
377    my $fileno = fileno($open_as);
378    $fd->{handle}->fdopen(defined($fileno)
379                  ? $saved{$fileno} || $open_as
380                  : $open_as,
381                  $fd->{mode});
382    }
383    unless ($^O eq 'MSWin32') {
384	require Fcntl;
385	# Stderr may be redirected below, so we save the err text:
386	foreach $fd (@$close_in_child) {
387	    next unless fileno $fd;
388	    fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!"
389		unless $saved{fileno $fd}; # Do not close what we redirect!
390	}
391    }
392
393    my $pid;
394    unless (@errs) {
395	if (FORCE_DEBUG_SPAWN) {
396	    pipe my $r, my $w or die "Pipe failed: $!";
397	    $pid = fork;
398	    die "Fork failed: $!" unless defined $pid;
399	    if (!$pid) {
400		{ no warnings; exec @_ }
401		print $w 0 + $!;
402		close $w;
403		require POSIX;
404		POSIX::_exit(255);
405	    }
406	    close $w;
407	    my $bad = <$r>;
408	    if (defined $bad) {
409		$! = $bad;
410		undef $pid;
411	    }
412	} else {
413	    $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
414	}
415	if($@) {
416	    push @errs, "IO::Pipe: Can't spawn-NOWAIT: $@";
417	} elsif(!$pid || $pid < 0) {
418	    push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!";
419	}
420    }
421
422    # Do this in reverse, so that STDERR is restored first:
423    foreach $fd (reverse @$fds) {
424	$fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode});
425    }
426    foreach (values %saved) {
427	$_->close or croak "Can't close: $!";
428    }
429    croak join "\n", @errs if @errs;
430    return $pid;
431}
432
4331; # so require is happy
434