[perl5.git] / lib / IPC / Open3.pm

package IPC::Open3;

use strict;
no strict 'refs'; # because users pass me bareword filehandles
use vars qw($VERSION @ISA @EXPORT $Fh $Me);

require 5.001;
require Exporter;

use Carp;
use Symbol 'qualify';

$VERSION	= 1.0101;
@ISA		= qw(Exporter);
@EXPORT		= qw(open3);

=head1 NAME

IPC::Open3, open3 - open a process for reading, writing, and error handling

=head1 SYNOPSIS

    $pid = open3(\*WTRFH, \*RDRFH, \*ERRFH
		    'some cmd and args', 'optarg', ...);

=head1 DESCRIPTION

Extremely similar to open2(), open3() spawns the given $cmd and
connects RDRFH for reading, WTRFH for writing, and ERRFH for errors.  If
ERRFH is '', or the same as RDRFH, then STDOUT and STDERR of the child are
on the same file handle.  The WTRFH will have autoflush turned on.

If WTRFH begins with "E<lt>&", then WTRFH will be closed in the parent, and
the child will read from it directly.  If RDRFH or ERRFH begins with
"E<gt>&", then the child will send output directly to that file handle.
In both cases, there will be a dup(2) instead of a pipe(2) made.

If you try to read from the child's stdout writer and their stderr
writer, you'll have problems with blocking, which means you'll
want to use select(), which means you'll have to use sysread() instead
of normal stuff.

open3() returns the process ID of the child process.  It doesn't return on
failure: it just raises an exception matching C</^open3:/>.

=head1 WARNING

It will not create these file handles for you.  You have to do this
yourself.  So don't pass it empty variables expecting them to get filled
in for you.

Additionally, this is very dangerous as you may block forever.  It
assumes it's going to talk to something like B<bc>, both writing to it
and reading from it.  This is presumably safe because you "know" that
commands like B<bc> will read a line at a time and output a line at a
time.  Programs like B<sort> that read their entire input stream first,
however, are quite apt to cause deadlock.

The big problem with this approach is that if you don't have control
over source code being run in the the child process, you can't control
what it does with pipe buffering.  Thus you can't just open a pipe to
C<cat -v> and continually read and write a line from it.

=cut

# &open3: Marc Horowitz <marc@mit.edu>
# derived mostly from &open2 by tom christiansen, <tchrist@convex.com>
# fixed for 5.001 by Ulrich Kunitz <kunitz@mai-koeln.com>
#
# $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $
#
# usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...);
#
# spawn the given $cmd and connect rdr for
# reading, wtr for writing, and err for errors.
# if err is '', or the same as rdr, then stdout and
# stderr of the child are on the same fh.  returns pid
# of child (or dies on failure).


# if wtr begins with '<&', then wtr will be closed in the parent, and
# the child will read from it directly.  if rdr or err begins with
# '>&', then the child will send output directly to that fd.  In both
# cases, there will be a dup() instead of a pipe() made.


# WARNING: this is dangerous, as you may block forever
# unless you are very careful.
#
# $wtr is left unbuffered.
#
# abort program if
#   rdr or wtr are null
#   a system call fails

$Fh = 'FHOPEN000';	# package static in case called more than once
$Me = 'open3 (bug)';	# you should never see this, it's always localized

# Fatal.pm needs to be fixed WRT prototypes.

sub xfork {
    my $pid = fork;
    defined $pid or croak "$Me: fork failed: $!";
    return $pid;
}

sub xpipe {
    pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!";
}

# I tried using a * prototype character for the filehandle but it still
# disallows a bearword while compiling under strict subs.

sub xopen {
    open $_[0], $_[1] or croak "$Me: open($_[0], $_[1]) failed: $!";
}

sub xclose {
    close $_[0] or croak "$Me: close($_[0]) failed: $!";
}

my $do_spawn = $^O eq 'os2';

sub _open3 {
    local $Me = shift;
    my($package, $dad_wtr, $dad_rdr, $dad_err, @cmd) = @_;
    my($dup_wtr, $dup_rdr, $dup_err, $kidpid);

    $dad_wtr			or croak "$Me: wtr should not be null";
    $dad_rdr			or croak "$Me: rdr should not be null";
    $dad_err = $dad_rdr if ($dad_err eq '');

    $dup_wtr = ($dad_wtr =~ s/^[<>]&//);
    $dup_rdr = ($dad_rdr =~ s/^[<>]&//);
    $dup_err = ($dad_err =~ s/^[<>]&//);

    # force unqualified filehandles into callers' package
    $dad_wtr = qualify $dad_wtr, $package;
    $dad_rdr = qualify $dad_rdr, $package;
    $dad_err = qualify $dad_err, $package;

    my $kid_rdr = ++$Fh;
    my $kid_wtr = ++$Fh;
    my $kid_err = ++$Fh;

    xpipe $kid_rdr, $dad_wtr if !$dup_wtr;
    xpipe $dad_rdr, $kid_wtr if !$dup_rdr;
    xpipe $dad_err, $kid_err if !$dup_err && $dad_err ne $dad_rdr;

    $kidpid = $do_spawn ? -1 : xfork;
    if ($kidpid == 0) {		# Kid
	# If she wants to dup the kid's stderr onto her stdout I need to
	# save a copy of her stdout before I put something else there.
	if ($dad_rdr ne $dad_err && $dup_err
		&& fileno($dad_err) == fileno(STDOUT)) {
	    my $tmp = ++$Fh;
	    xopen($tmp, ">&$dad_err");
	    $dad_err = $tmp;
	}

	if ($dup_wtr) {
	    xopen \*STDIN,  "<&$dad_wtr" if fileno(STDIN) != fileno($dad_wtr);
	} else {
	    xclose $dad_wtr;
	    xopen \*STDIN,  "<&$kid_rdr";
	    xclose $kid_rdr;
	}
	if ($dup_rdr) {
	    xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != fileno($dad_rdr);
	} else {
	    xclose $dad_rdr;
	    xopen \*STDOUT, ">&$kid_wtr";
	    xclose $kid_wtr;
	}
	if ($dad_rdr ne $dad_err) {
	    if ($dup_err) {
		xopen \*STDERR, ">&$dad_err"
		    if fileno(STDERR) != fileno($dad_err);
	    } else {
		xclose $dad_err;
		xopen \*STDERR, ">&$kid_err";
		xclose $kid_err;
	    }
	} else {
	    xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT);
	}
	local($")=(" ");
	exec @cmd
	    or croak "open3: exec of @cmd failed";
    } elsif ($do_spawn) {
	# All the bookkeeping of coincidence between handles is
	# handled in spawn_with_handles.

	my @close;
	if ($dup_wtr) {
	  $kid_rdr = $dad_wtr;
	  push @close, \*{$kid_rdr};
	} else {
	  push @close, \*{$dad_wtr}, \*{$kid_rdr};
	}
	if ($dup_rdr) {
	  $kid_wtr = $dad_rdr;
	  push @close, \*{$kid_wtr};
	} else {
	  push @close, \*{$dad_rdr}, \*{$kid_wtr};
	}
	if ($dad_rdr ne $dad_err) {
	    if ($dup_err) {
	      $kid_err = $dad_err ;
	      push @close, \*{$kid_err};
	    } else {
	      push @close, \*{$dad_err}, \*{$kid_err};
	    }
	} else {
	  $kid_err = $kid_wtr;
	}
	require IO::Pipe;
	$kidpid = eval {
	    spawn_with_handles( [ { mode => 'r',
				    open_as => \*{$kid_rdr},
				    handle => \*STDIN },
				  { mode => 'w',
				    open_as => \*{$kid_wtr},
				    handle => \*STDOUT },
				  { mode => 'w',
				    open_as => \*{$kid_err},
				    handle => \*STDERR },
				], \@close, @cmd);
	};
	die "open3: $@" if $@;
    }

    xclose $kid_rdr if !$dup_wtr;
    xclose $kid_wtr if !$dup_rdr;
    xclose $kid_err if !$dup_err && $dad_rdr ne $dad_err;
    # If the write handle is a dup give it away entirely, close my copy
    # of it.
    xclose $dad_wtr if $dup_wtr;

    select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
    $kidpid;
}

sub open3 {
    if (@_ < 4) {
	local $" = ', ';
	croak "open3(@_): not enough arguments";
    }
    return _open3 'open3', scalar caller, @_
}

sub spawn_with_handles {
    my $fds = shift;		# Fields: handle, mode, open_as
    my $close_in_child = shift;
    my ($fd, $pid, @saved_fh, $saved, %saved, @errs);
    require Fcntl;

    foreach $fd (@$fds) {
	$fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode});
	$saved{fileno $fd->{handle}} = $fd->{tmp_copy};
    }
    foreach $fd (@$fds) {
	bless $fd->{handle}, 'IO::Handle'
	    unless eval { $fd->{handle}->isa('IO::Handle') } ;
	# If some of handles to redirect-to coincide with handles to
	# redirect, we need to use saved variants:
	$fd->{handle}->fdopen($saved{fileno $fd->{open_as}} || $fd->{open_as},
			      $fd->{mode});
    }
    # Stderr may be redirected below, so we save the err text:
    foreach $fd (@$close_in_child) {
	fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!"
	    unless $saved{fileno $fd};	# Do not close what we redirect!
    }

    unless (@errs) {
	$pid = eval { system 1, @_ }; # 1 == P_NOWAIT
	push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!" if !$pid || $pid < 0;
    }

    foreach $fd (@$fds) {
	$fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode});
	$fd->{tmp_copy}->close or croak "Can't close: $!";
    }
    croak join "\n", @errs if @errs;
    return $pid;
}

1; # so require is happy
Commit	Line	Data
a0d0e21e	1	package IPC::Open3;
7e1af8bc	2
	3	use strict;
	4	no strict 'refs'; # because users pass me bareword filehandles
	5	use vars qw($VERSION @ISA @EXPORT $Fh $Me);
	6
4633a7c4	7	require 5.001;
a0d0e21e	8	require Exporter;
7e1af8bc	9
a0d0e21e	10	use Carp;
7e1af8bc	11	use Symbol 'qualify';
7e1af8bc	12
a24d8dfd	13	$VERSION = 1.0101;
7e1af8bc	14	@ISA = qw(Exporter);
7e1af8bc	15	@EXPORT = qw(open3);
a0d0e21e	16
f06db76b AD	17	=head1 NAME
	18
	19	IPC::Open3, open3 - open a process for reading, writing, and error handling
	20
	21	=head1 SYNOPSIS
	22
7e1af8bc	23	$pid = open3(\WTRFH, \RDRFH, \*ERRFH
f06db76b AD	24	'some cmd and args', 'optarg', ...);
	25
	26	=head1 DESCRIPTION
	27
	28	Extremely similar to open2(), open3() spawns the given $cmd and
	29	connects RDRFH for reading, WTRFH for writing, and ERRFH for errors. If
	30	ERRFH is '', or the same as RDRFH, then STDOUT and STDERR of the child are
eeba3357	31	on the same file handle. The WTRFH will have autoflush turned on.
f06db76b	32
1fef88e7	33	If WTRFH begins with "E<lt>&", then WTRFH will be closed in the parent, and
4633a7c4	34	the child will read from it directly. If RDRFH or ERRFH begins with
a24d8dfd IZ	35	"E<gt>&", then the child will send output directly to that file handle.
a24d8dfd IZ	36	In both cases, there will be a dup(2) instead of a pipe(2) made.
f06db76b	37
cb1a09d0 AD	38	If you try to read from the child's stdout writer and their stderr
	39	writer, you'll have problems with blocking, which means you'll
	40	want to use select(), which means you'll have to use sysread() instead
	41	of normal stuff.
	42
7e1af8bc	43	open3() returns the process ID of the child process. It doesn't return on
7e1af8bc	44	failure: it just raises an exception matching C</^open3:/>.
f06db76b	45
7e1af8bc	46	=head1 WARNING
	47
	48	It will not create these file handles for you. You have to do this
	49	yourself. So don't pass it empty variables expecting them to get filled
	50	in for you.
f06db76b	51
7e1af8bc	52	Additionally, this is very dangerous as you may block forever. It
	53	assumes it's going to talk to something like B<bc>, both writing to it
	54	and reading from it. This is presumably safe because you "know" that
	55	commands like B<bc> will read a line at a time and output a line at a
	56	time. Programs like B<sort> that read their entire input stream first,
	57	however, are quite apt to cause deadlock.
	58
	59	The big problem with this approach is that if you don't have control
	60	over source code being run in the the child process, you can't control
	61	what it does with pipe buffering. Thus you can't just open a pipe to
	62	C<cat -v> and continually read and write a line from it.
	63
	64	=cut
a0d0e21e LW	65
	66	# &open3: Marc Horowitz <marc@mit.edu>
	67	# derived mostly from &open2 by tom christiansen, <tchrist@convex.com>
4633a7c4	68	# fixed for 5.001 by Ulrich Kunitz <kunitz@mai-koeln.com>
a0d0e21e LW	69	#
	70	# $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $
	71	#
	72	# usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...);
	73	#
	74	# spawn the given $cmd and connect rdr for
	75	# reading, wtr for writing, and err for errors.
	76	# if err is '', or the same as rdr, then stdout and
	77	# stderr of the child are on the same fh. returns pid
7e1af8bc	78	# of child (or dies on failure).
a0d0e21e LW	79
a0d0e21e LW	80
4633a7c4	81	# if wtr begins with '<&', then wtr will be closed in the parent, and
a0d0e21e LW	82	# the child will read from it directly. if rdr or err begins with
	83	# '>&', then the child will send output directly to that fd. In both
	84	# cases, there will be a dup() instead of a pipe() made.
	85
	86
	87	# WARNING: this is dangerous, as you may block forever
	88	# unless you are very careful.
	89	#
	90	# $wtr is left unbuffered.
	91	#
	92	# abort program if
	93	# rdr or wtr are null
7e1af8bc	94	# a system call fails
a0d0e21e	95
7e1af8bc	96	$Fh = 'FHOPEN000'; # package static in case called more than once
7e1af8bc	97	$Me = 'open3 (bug)'; # you should never see this, it's always localized
a0d0e21e	98
7e1af8bc	99	# Fatal.pm needs to be fixed WRT prototypes.
	100
	101	sub xfork {
	102	my $pid = fork;
	103	defined $pid or croak "$Me: fork failed: $!";
	104	return $pid;
	105	}
	106
	107	sub xpipe {
	108	pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!";
	109	}
	110
	111	# I tried using a * prototype character for the filehandle but it still
	112	# disallows a bearword while compiling under strict subs.
a0d0e21e	113
7e1af8bc	114	sub xopen {
	115	open $_[0], $_[1] or croak "$Me: open($_[0], $_[1]) failed: $!";
	116	}
	117
	118	sub xclose {
	119	close $_[0] or croak "$Me: close($_[0]) failed: $!";
	120	}
	121
a24d8dfd IZ	122	my $do_spawn = $^O eq 'os2';
a24d8dfd IZ	123
7e1af8bc	124	sub _open3 {
	125	local $Me = shift;
	126	my($package, $dad_wtr, $dad_rdr, $dad_err, @cmd) = @_;
	127	my($dup_wtr, $dup_rdr, $dup_err, $kidpid);
	128
	129	$dad_wtr or croak "$Me: wtr should not be null";
	130	$dad_rdr or croak "$Me: rdr should not be null";
a0d0e21e LW	131	$dad_err = $dad_rdr if ($dad_err eq '');
a0d0e21e LW	132
4633a7c4 LW	133	$dup_wtr = ($dad_wtr =~ s/^[<>]&//);
	134	$dup_rdr = ($dad_rdr =~ s/^[<>]&//);
	135	$dup_err = ($dad_err =~ s/^[<>]&//);
a0d0e21e LW	136
a0d0e21e LW	137	# force unqualified filehandles into callers' package
7e1af8bc	138	$dad_wtr = qualify $dad_wtr, $package;
	139	$dad_rdr = qualify $dad_rdr, $package;
	140	$dad_err = qualify $dad_err, $package;
	141
	142	my $kid_rdr = ++$Fh;
	143	my $kid_wtr = ++$Fh;
	144	my $kid_err = ++$Fh;
	145
	146	xpipe $kid_rdr, $dad_wtr if !$dup_wtr;
	147	xpipe $dad_rdr, $kid_wtr if !$dup_rdr;
	148	xpipe $dad_err, $kid_err if !$dup_err && $dad_err ne $dad_rdr;
	149
a24d8dfd IZ	150	$kidpid = $do_spawn ? -1 : xfork;
a24d8dfd IZ	151	if ($kidpid == 0) { # Kid
7e1af8bc	152	# If she wants to dup the kid's stderr onto her stdout I need to
	153	# save a copy of her stdout before I put something else there.
	154	if ($dad_rdr ne $dad_err && $dup_err
	155	&& fileno($dad_err) == fileno(STDOUT)) {
	156	my $tmp = ++$Fh;
	157	xopen($tmp, ">&$dad_err");
	158	$dad_err = $tmp;
	159	}
a0d0e21e	160
a0d0e21e	161	if ($dup_wtr) {
8ebc5c01	162	xopen \*STDIN, "<&$dad_wtr" if fileno(STDIN) != fileno($dad_wtr);
a0d0e21e	163	} else {
8ebc5c01	164	xclose $dad_wtr;
	165	xopen \*STDIN, "<&$kid_rdr";
	166	xclose $kid_rdr;
a0d0e21e LW	167	}
a0d0e21e LW	168	if ($dup_rdr) {
8ebc5c01	169	xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != fileno($dad_rdr);
a0d0e21e	170	} else {
8ebc5c01	171	xclose $dad_rdr;
	172	xopen \*STDOUT, ">&$kid_wtr";
	173	xclose $kid_wtr;
a0d0e21e LW	174	}
	175	if ($dad_rdr ne $dad_err) {
	176	if ($dup_err) {
8ebc5c01	177	xopen \*STDERR, ">&$dad_err"
8ebc5c01	178	if fileno(STDERR) != fileno($dad_err);
a0d0e21e	179	} else {
8ebc5c01	180	xclose $dad_err;
	181	xopen \*STDERR, ">&$kid_err";
	182	xclose $kid_err;
a0d0e21e LW	183	}
a0d0e21e LW	184	} else {
8ebc5c01	185	xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT);
a0d0e21e LW	186	}
a0d0e21e LW	187	local($")=(" ");
c07a80fd	188	exec @cmd
c07a80fd	189	or croak "open3: exec of @cmd failed";
a24d8dfd IZ	190	} elsif ($do_spawn) {
	191	# All the bookkeeping of coincidence between handles is
	192	# handled in spawn_with_handles.
	193
	194	my @close;
	195	if ($dup_wtr) {
	196	$kid_rdr = $dad_wtr;
	197	push @close, \*{$kid_rdr};
	198	} else {
	199	push @close, \{$dad_wtr}, \{$kid_rdr};
	200	}
	201	if ($dup_rdr) {
	202	$kid_wtr = $dad_rdr;
	203	push @close, \*{$kid_wtr};
	204	} else {
	205	push @close, \{$dad_rdr}, \{$kid_wtr};
	206	}
	207	if ($dad_rdr ne $dad_err) {
	208	if ($dup_err) {
	209	$kid_err = $dad_err ;
	210	push @close, \*{$kid_err};
	211	} else {
	212	push @close, \{$dad_err}, \{$kid_err};
	213	}
	214	} else {
	215	$kid_err = $kid_wtr;
	216	}
	217	require IO::Pipe;
	218	$kidpid = eval {
	219	spawn_with_handles( [ { mode => 'r',
	220	open_as => \*{$kid_rdr},
	221	handle => \*STDIN },
	222	{ mode => 'w',
	223	open_as => \*{$kid_wtr},
	224	handle => \*STDOUT },
	225	{ mode => 'w',
	226	open_as => \*{$kid_err},
	227	handle => \*STDERR },
	228	], \@close, @cmd);
	229	};
	230	die "open3: $@" if $@;
a0d0e21e LW	231	}
a0d0e21e LW	232
7e1af8bc	233	xclose $kid_rdr if !$dup_wtr;
	234	xclose $kid_wtr if !$dup_rdr;
	235	xclose $kid_err if !$dup_err && $dad_rdr ne $dad_err;
	236	# If the write handle is a dup give it away entirely, close my copy
	237	# of it.
	238	xclose $dad_wtr if $dup_wtr;
a0d0e21e LW	239
	240	select((select($dad_wtr), $\| = 1)[0]); # unbuffer pipe
	241	$kidpid;
	242	}
7e1af8bc	243
7e1af8bc	244	sub open3 {
a24d8dfd IZ	245	if (@_ < 4) {
	246	local $" = ', ';
	247	croak "open3(@_): not enough arguments";
	248	}
7e1af8bc	249	return _open3 'open3', scalar caller, @_
7e1af8bc	250	}
a0d0e21e	251
a24d8dfd IZ	252	sub spawn_with_handles {
	253	my $fds = shift; # Fields: handle, mode, open_as
	254	my $close_in_child = shift;
	255	my ($fd, $pid, @saved_fh, $saved, %saved, @errs);
	256	require Fcntl;
	257
	258	foreach $fd (@$fds) {
	259	$fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode});
	260	$saved{fileno $fd->{handle}} = $fd->{tmp_copy};
	261	}
	262	foreach $fd (@$fds) {
	263	bless $fd->{handle}, 'IO::Handle'
	264	unless eval { $fd->{handle}->isa('IO::Handle') } ;
	265	# If some of handles to redirect-to coincide with handles to
	266	# redirect, we need to use saved variants:
	267	$fd->{handle}->fdopen($saved{fileno $fd->{open_as}} \|\| $fd->{open_as},
	268	$fd->{mode});
	269	}
	270	# Stderr may be redirected below, so we save the err text:
	271	foreach $fd (@$close_in_child) {
	272	fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!"
	273	unless $saved{fileno $fd}; # Do not close what we redirect!
	274	}
	275
	276	unless (@errs) {
	277	$pid = eval { system 1, @_ }; # 1 == P_NOWAIT
	278	push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!" if !$pid \|\| $pid < 0;
	279	}
	280
	281	foreach $fd (@$fds) {
	282	$fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode});
	283	$fd->{tmp_copy}->close or croak "Can't close: $!";
	284	}
	285	croak join "\n", @errs if @errs;
	286	return $pid;
	287	}
	288
	289	1; # so require is happy