[p5sagit/p5-mst-13.2.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.0102;
@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 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>
# ported to Win32 by Ron Schmidt, Merrill Lynch almost ended my career
#
# $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' || $^O eq 'MSWin32';

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 "$Me: 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 "$Me: $@" 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});
    }
    unless ($^O eq 'MSWin32') {
	# 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
f55ee38a	13	$VERSION = 1.0102;
7e1af8bc	14	@ISA = qw(Exporter);
7e1af8bc	15	@EXPORT = qw(open3);
a0d0e21e	16
f06db76b	17	=head1 NAME
	18
	19	IPC::Open3, open3 - open a process for reading, writing, and error handling
	20
	21	=head1 SYNOPSIS
	22
84902520	23	$pid = open3(\WTRFH, \RDRFH, \*ERRFH,
f06db76b	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	35	"E<gt>&", then the child will send output directly to that file handle.
a24d8dfd	36	In both cases, there will be a dup(2) instead of a pipe(2) made.
f06db76b	37
cb1a09d0	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
7a2e2cd6	60	over source code being run in the child process, you can't control
7e1af8bc	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	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>
f55ee38a	69	# ported to Win32 by Ron Schmidt, Merrill Lynch almost ended my career
a0d0e21e	70	#
	71	# $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $
	72	#
	73	# usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...);
	74	#
	75	# spawn the given $cmd and connect rdr for
	76	# reading, wtr for writing, and err for errors.
	77	# if err is '', or the same as rdr, then stdout and
	78	# stderr of the child are on the same fh. returns pid
7e1af8bc	79	# of child (or dies on failure).
a0d0e21e	80
a0d0e21e	81
4633a7c4	82	# if wtr begins with '<&', then wtr will be closed in the parent, and
a0d0e21e	83	# the child will read from it directly. if rdr or err begins with
	84	# '>&', then the child will send output directly to that fd. In both
	85	# cases, there will be a dup() instead of a pipe() made.
	86
	87
	88	# WARNING: this is dangerous, as you may block forever
	89	# unless you are very careful.
	90	#
	91	# $wtr is left unbuffered.
	92	#
	93	# abort program if
	94	# rdr or wtr are null
7e1af8bc	95	# a system call fails
a0d0e21e	96
7e1af8bc	97	$Fh = 'FHOPEN000'; # package static in case called more than once
7e1af8bc	98	$Me = 'open3 (bug)'; # you should never see this, it's always localized
a0d0e21e	99
7e1af8bc	100	# Fatal.pm needs to be fixed WRT prototypes.
	101
	102	sub xfork {
	103	my $pid = fork;
	104	defined $pid or croak "$Me: fork failed: $!";
	105	return $pid;
	106	}
	107
	108	sub xpipe {
	109	pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!";
	110	}
	111
	112	# I tried using a * prototype character for the filehandle but it still
	113	# disallows a bearword while compiling under strict subs.
a0d0e21e	114
7e1af8bc	115	sub xopen {
	116	open $_[0], $_[1] or croak "$Me: open($_[0], $_[1]) failed: $!";
	117	}
	118
	119	sub xclose {
	120	close $_[0] or croak "$Me: close($_[0]) failed: $!";
	121	}
	122
f55ee38a	123	my $do_spawn = $^O eq 'os2' \|\| $^O eq 'MSWin32';
a24d8dfd	124
7e1af8bc	125	sub _open3 {
	126	local $Me = shift;
	127	my($package, $dad_wtr, $dad_rdr, $dad_err, @cmd) = @_;
	128	my($dup_wtr, $dup_rdr, $dup_err, $kidpid);
	129
	130	$dad_wtr or croak "$Me: wtr should not be null";
	131	$dad_rdr or croak "$Me: rdr should not be null";
a0d0e21e	132	$dad_err = $dad_rdr if ($dad_err eq '');
a0d0e21e	133
4633a7c4	134	$dup_wtr = ($dad_wtr =~ s/^[<>]&//);
	135	$dup_rdr = ($dad_rdr =~ s/^[<>]&//);
	136	$dup_err = ($dad_err =~ s/^[<>]&//);
a0d0e21e	137
a0d0e21e	138	# force unqualified filehandles into callers' package
7e1af8bc	139	$dad_wtr = qualify $dad_wtr, $package;
	140	$dad_rdr = qualify $dad_rdr, $package;
	141	$dad_err = qualify $dad_err, $package;
	142
	143	my $kid_rdr = ++$Fh;
	144	my $kid_wtr = ++$Fh;
	145	my $kid_err = ++$Fh;
	146
	147	xpipe $kid_rdr, $dad_wtr if !$dup_wtr;
	148	xpipe $dad_rdr, $kid_wtr if !$dup_rdr;
	149	xpipe $dad_err, $kid_err if !$dup_err && $dad_err ne $dad_rdr;
	150
a24d8dfd	151	$kidpid = $do_spawn ? -1 : xfork;
a24d8dfd	152	if ($kidpid == 0) { # Kid
7e1af8bc	153	# If she wants to dup the kid's stderr onto her stdout I need to
	154	# save a copy of her stdout before I put something else there.
	155	if ($dad_rdr ne $dad_err && $dup_err
	156	&& fileno($dad_err) == fileno(STDOUT)) {
	157	my $tmp = ++$Fh;
	158	xopen($tmp, ">&$dad_err");
	159	$dad_err = $tmp;
	160	}
a0d0e21e	161
a0d0e21e	162	if ($dup_wtr) {
8ebc5c01	163	xopen \*STDIN, "<&$dad_wtr" if fileno(STDIN) != fileno($dad_wtr);
a0d0e21e	164	} else {
8ebc5c01	165	xclose $dad_wtr;
	166	xopen \*STDIN, "<&$kid_rdr";
	167	xclose $kid_rdr;
a0d0e21e	168	}
a0d0e21e	169	if ($dup_rdr) {
8ebc5c01	170	xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != fileno($dad_rdr);
a0d0e21e	171	} else {
8ebc5c01	172	xclose $dad_rdr;
	173	xopen \*STDOUT, ">&$kid_wtr";
	174	xclose $kid_wtr;
a0d0e21e	175	}
	176	if ($dad_rdr ne $dad_err) {
	177	if ($dup_err) {
8ebc5c01	178	xopen \*STDERR, ">&$dad_err"
8ebc5c01	179	if fileno(STDERR) != fileno($dad_err);
a0d0e21e	180	} else {
8ebc5c01	181	xclose $dad_err;
	182	xopen \*STDERR, ">&$kid_err";
	183	xclose $kid_err;
a0d0e21e	184	}
a0d0e21e	185	} else {
8ebc5c01	186	xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT);
a0d0e21e	187	}
a0d0e21e	188	local($")=(" ");
c07a80fd	189	exec @cmd
ad973f30	190	or croak "$Me: exec of @cmd failed";
a24d8dfd	191	} elsif ($do_spawn) {
	192	# All the bookkeeping of coincidence between handles is
	193	# handled in spawn_with_handles.
	194
	195	my @close;
	196	if ($dup_wtr) {
	197	$kid_rdr = $dad_wtr;
	198	push @close, \*{$kid_rdr};
	199	} else {
	200	push @close, \{$dad_wtr}, \{$kid_rdr};
	201	}
	202	if ($dup_rdr) {
	203	$kid_wtr = $dad_rdr;
	204	push @close, \*{$kid_wtr};
	205	} else {
	206	push @close, \{$dad_rdr}, \{$kid_wtr};
	207	}
	208	if ($dad_rdr ne $dad_err) {
	209	if ($dup_err) {
	210	$kid_err = $dad_err ;
	211	push @close, \*{$kid_err};
	212	} else {
	213	push @close, \{$dad_err}, \{$kid_err};
	214	}
	215	} else {
	216	$kid_err = $kid_wtr;
	217	}
	218	require IO::Pipe;
	219	$kidpid = eval {
	220	spawn_with_handles( [ { mode => 'r',
	221	open_as => \*{$kid_rdr},
	222	handle => \*STDIN },
	223	{ mode => 'w',
	224	open_as => \*{$kid_wtr},
	225	handle => \*STDOUT },
	226	{ mode => 'w',
	227	open_as => \*{$kid_err},
	228	handle => \*STDERR },
	229	], \@close, @cmd);
	230	};
ad973f30	231	die "$Me: $@" if $@;
a0d0e21e	232	}
a0d0e21e	233
7e1af8bc	234	xclose $kid_rdr if !$dup_wtr;
	235	xclose $kid_wtr if !$dup_rdr;
	236	xclose $kid_err if !$dup_err && $dad_rdr ne $dad_err;
	237	# If the write handle is a dup give it away entirely, close my copy
	238	# of it.
	239	xclose $dad_wtr if $dup_wtr;
a0d0e21e	240
	241	select((select($dad_wtr), $\| = 1)[0]); # unbuffer pipe
	242	$kidpid;
	243	}
7e1af8bc	244
7e1af8bc	245	sub open3 {
a24d8dfd	246	if (@_ < 4) {
	247	local $" = ', ';
	248	croak "open3(@_): not enough arguments";
	249	}
7e1af8bc	250	return _open3 'open3', scalar caller, @_
7e1af8bc	251	}
a0d0e21e	252
a24d8dfd	253	sub spawn_with_handles {
	254	my $fds = shift; # Fields: handle, mode, open_as
	255	my $close_in_child = shift;
	256	my ($fd, $pid, @saved_fh, $saved, %saved, @errs);
	257	require Fcntl;
	258
	259	foreach $fd (@$fds) {
	260	$fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode});
	261	$saved{fileno $fd->{handle}} = $fd->{tmp_copy};
	262	}
	263	foreach $fd (@$fds) {
	264	bless $fd->{handle}, 'IO::Handle'
	265	unless eval { $fd->{handle}->isa('IO::Handle') } ;
	266	# If some of handles to redirect-to coincide with handles to
	267	# redirect, we need to use saved variants:
	268	$fd->{handle}->fdopen($saved{fileno $fd->{open_as}} \|\| $fd->{open_as},
	269	$fd->{mode});
	270	}
f55ee38a	271	unless ($^O eq 'MSWin32') {
	272	# Stderr may be redirected below, so we save the err text:
	273	foreach $fd (@$close_in_child) {
	274	fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!"
	275	unless $saved{fileno $fd}; # Do not close what we redirect!
	276	}
a24d8dfd	277	}
	278
	279	unless (@errs) {
	280	$pid = eval { system 1, @_ }; # 1 == P_NOWAIT
	281	push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!" if !$pid \|\| $pid < 0;
	282	}
	283
	284	foreach $fd (@$fds) {
	285	$fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode});
	286	$fd->{tmp_copy}->close or croak "Can't close: $!";
	287	}
	288	croak join "\n", @errs if @errs;
	289	return $pid;
	290	}
	291
	292	1; # so require is happy