[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 $Me);

require 5.001;
require Exporter;

use Carp;
use Symbol qw(gensym qualify);

$VERSION	= 1.0103;
@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

$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 = gensym;
    my $kid_wtr = gensym;
    my $kid_err = gensym;

    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 = gensym;
	    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,  "<&=" . fileno $kid_rdr;
	}
	if ($dup_rdr) {
	    xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != fileno($dad_rdr);
	} else {
	    xclose $dad_rdr;
	    xopen \*STDOUT, ">&=" . fileno $kid_wtr;
	}
	if ($dad_rdr ne $dad_err) {
	    if ($dup_err) {
		# I have to use a fileno here because in this one case
		# I'm doing a dup but the filehandle might be a reference
		# (from the special case above).
		xopen \*STDERR, ">&" . fileno $dad_err
		    if fileno(STDERR) != fileno($dad_err);
	    } else {
		xclose $dad_err;
		xopen \*STDERR, ">&=" . fileno $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
8b3e92c6	5	use vars qw($VERSION @ISA @EXPORT $Me);
7e1af8bc	6
4633a7c4	7	require 5.001;
a0d0e21e	8	require Exporter;
7e1af8bc	9
a0d0e21e	10	use Carp;
8b3e92c6	11	use Symbol qw(gensym qualify);
7e1af8bc	12
8b3e92c6	13	$VERSION = 1.0103;
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	$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
f55ee38a	122	my $do_spawn = $^O eq 'os2' \|\| $^O eq 'MSWin32';
a24d8dfd	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	131	$dad_err = $dad_rdr if ($dad_err eq '');
a0d0e21e	132
4633a7c4	133	$dup_wtr = ($dad_wtr =~ s/^[<>]&//);
	134	$dup_rdr = ($dad_rdr =~ s/^[<>]&//);
	135	$dup_err = ($dad_err =~ s/^[<>]&//);
a0d0e21e	136
a0d0e21e	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
8b3e92c6	142	my $kid_rdr = gensym;
	143	my $kid_wtr = gensym;
	144	my $kid_err = gensym;
7e1af8bc	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	150	$kidpid = $do_spawn ? -1 : xfork;
a24d8dfd	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)) {
8b3e92c6	156	my $tmp = gensym;
7e1af8bc	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;
8b3e92c6	165	xopen \*STDIN, "<&=" . fileno $kid_rdr;
a0d0e21e	166	}
a0d0e21e	167	if ($dup_rdr) {
8ebc5c01	168	xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != fileno($dad_rdr);
a0d0e21e	169	} else {
8ebc5c01	170	xclose $dad_rdr;
8b3e92c6	171	xopen \*STDOUT, ">&=" . fileno $kid_wtr;
a0d0e21e	172	}
	173	if ($dad_rdr ne $dad_err) {
	174	if ($dup_err) {
8b3e92c6	175	# I have to use a fileno here because in this one case
	176	# I'm doing a dup but the filehandle might be a reference
	177	# (from the special case above).
	178	xopen \*STDERR, ">&" . fileno $dad_err
8ebc5c01	179	if fileno(STDERR) != fileno($dad_err);
a0d0e21e	180	} else {
8ebc5c01	181	xclose $dad_err;
8b3e92c6	182	xopen \*STDERR, ">&=" . fileno $kid_err;
a0d0e21e	183	}
a0d0e21e	184	} else {
8ebc5c01	185	xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT);
a0d0e21e	186	}
a0d0e21e	187	local($")=(" ");
c07a80fd	188	exec @cmd
ad973f30	189	or croak "$Me: exec of @cmd failed";
a24d8dfd	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) {
8b3e92c6	196	$kid_rdr = \*{$dad_wtr};
8b3e92c6	197	push @close, $kid_rdr;
a24d8dfd	198	} else {
8b3e92c6	199	push @close, \*{$dad_wtr}, $kid_rdr;
a24d8dfd	200	}
a24d8dfd	201	if ($dup_rdr) {
8b3e92c6	202	$kid_wtr = \*{$dad_rdr};
8b3e92c6	203	push @close, $kid_wtr;
a24d8dfd	204	} else {
8b3e92c6	205	push @close, \*{$dad_rdr}, $kid_wtr;
a24d8dfd	206	}
	207	if ($dad_rdr ne $dad_err) {
	208	if ($dup_err) {
8b3e92c6	209	$kid_err = \*{$dad_err};
8b3e92c6	210	push @close, $kid_err;
a24d8dfd	211	} else {
8b3e92c6	212	push @close, \*{$dad_err}, $kid_err;
a24d8dfd	213	}
	214	} else {
	215	$kid_err = $kid_wtr;
	216	}
	217	require IO::Pipe;
	218	$kidpid = eval {
	219	spawn_with_handles( [ { mode => 'r',
8b3e92c6	220	open_as => $kid_rdr,
a24d8dfd	221	handle => \*STDIN },
a24d8dfd	222	{ mode => 'w',
8b3e92c6	223	open_as => $kid_wtr,
a24d8dfd	224	handle => \*STDOUT },
a24d8dfd	225	{ mode => 'w',
8b3e92c6	226	open_as => $kid_err,
a24d8dfd	227	handle => \*STDERR },
	228	], \@close, @cmd);
	229	};
ad973f30	230	die "$Me: $@" if $@;
a0d0e21e	231	}
a0d0e21e	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	239
	240	select((select($dad_wtr), $\| = 1)[0]); # unbuffer pipe
	241	$kidpid;
	242	}
7e1af8bc	243
7e1af8bc	244	sub open3 {
a24d8dfd	245	if (@_ < 4) {
	246	local $" = ', ';
	247	croak "open3(@_): not enough arguments";
	248	}
7e1af8bc	249	return _open3 'open3', scalar caller, @_
7e1af8bc	250	}
a0d0e21e	251
a24d8dfd	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	}
f55ee38a	270	unless ($^O eq 'MSWin32') {
	271	# Stderr may be redirected below, so we save the err text:
	272	foreach $fd (@$close_in_child) {
	273	fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!"
	274	unless $saved{fileno $fd}; # Do not close what we redirect!
	275	}
a24d8dfd	276	}
	277
	278	unless (@errs) {
	279	$pid = eval { system 1, @_ }; # 1 == P_NOWAIT
	280	push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!" if !$pid \|\| $pid < 0;
	281	}
	282
	283	foreach $fd (@$fds) {
	284	$fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode});
	285	$fd->{tmp_copy}->close or croak "Can't close: $!";
	286	}
	287	croak join "\n", @errs if @errs;
	288	return $pid;
	289	}
	290
	291	1; # so require is happy