diff options
author | Perl 5 Porters <perl5-porters@africa.nicoh.com> | 1996-12-20 11:14:00 +1200 |
---|---|---|
committer | Chip Salzenberg <chip@atlantic.net> | 1996-12-20 11:14:00 +1200 |
commit | 7e1af8bca57f405a8444b575a870918a6d88fc5c (patch) | |
tree | b443adc34d8d77831bf947076abd5770335592cf /lib/IPC | |
parent | 7f3dfc00eaef7e421633b2b47af9963dbc626e75 (diff) | |
download | perl-7e1af8bca57f405a8444b575a870918a6d88fc5c.tar.gz |
[inseparable changes from patch from perl5.003_12 to perl5.003_13]
DOCUMENTATION
Subject: small doc tweaks for _12
Date: Thu, 19 Dec 1996 11:05:57 -0500
From: Roderick Schertler <roderick@gate.net>
Files: lib/UNIVERSAL.pm pod/perldiag.pod pod/perltie.pod
Msg-ID: <1826.851011557@eeyore.ibcinc.com>
(applied based on p5p patch as commit 3314ffc68a11690bd9977cbdd7ea0601ad6ced13)
PORTABILITY
Subject: Add missing backslash in Configure
From: Chip Salzenberg <chip@atlantic.net>
Files: Configure
UTILITIES, LIBRARY, AND EXTENSIONS
Subject: Include libnet-1.01 instead of old Net::FTP
From: Graham Barr <Graham.Barr@tiuk.ti.com>
Files: MANIFEST lib/Net/Cmd.pm lib/Net/Domain.pm lib/Net/DummyInetd.pm lib/Net/FTP.pm lib/Net/NNTP.pm lib/Net/Netrc.pm lib/Net/POP3.pm lib/Net/SMTP.pm lib/Net/SNPP.pm lib/Net/Socket.pm lib/Net/Telnet.pm lib/Net/Time.pm pod/perlmod.pod
Subject: Use binmode when doing binary FTP
From: Ilya Zakharevich <ilya@math.ohio-state.edu>
Files: lib/Net/FTP.pm
Subject: Re: Open3.pm tries to close unopened file handle
Date: 18 Dec 1996 22:19:54 -0500
From: Roderick Schertler <roderick@gate.net>
Files: MANIFEST lib/IPC/Open2.pm lib/IPC/Open3.pm lib/open2.pl lib/open3.pl pod/perldiag.pod pod/perlfunc.pod t/lib/open2.t t/lib/open3.t
Msg-ID: <pzloavmd9h.fsf@eeyore.ibcinc.com>
(applied based on p5p patch as commit 982b4e8fc47473059e209787b589853f4c8f8f9e)
Subject: Long-standing problem in Socket module
Date: Wed, 18 Dec 1996 23:18:14 -0500
From: Spider Boardman <spider@orb.nashua.nh.us>
Files: Configure Porting/Glossary config_H config_h.SH ext/Socket/Socket.pm ext/Socket/Socket.xs
Msg-ID: <199612190418.XAA07291@Orb.Nashua.NH.US>
(applied based on p5p patch as commit 3e6a22d2723daf415793f9a4fc1b57f4d8a576fd)
Subject: flock() constants
Date: Thu, 19 Dec 1996 01:37:17 -0500
From: Roderick Schertler <roderick@gate.net>
Files: ext/Fcntl/Fcntl.pm ext/Fcntl/Fcntl.xs pod/perlfunc.pod
Msg-ID: <26669.850977437@eeyore.ibcinc.com>
(applied based on p5p patch as commit 3dea0e15e4684f6defe2f25a16bc696b96697ac2)
Diffstat (limited to 'lib/IPC')
-rw-r--r-- | lib/IPC/Open2.pm | 62 | ||||
-rw-r--r-- | lib/IPC/Open3.pm | 136 |
2 files changed, 121 insertions, 77 deletions
diff --git a/lib/IPC/Open2.pm b/lib/IPC/Open2.pm index 35bb0d1f16..cfd15a848b 100644 --- a/lib/IPC/Open2.pm +++ b/lib/IPC/Open2.pm @@ -1,7 +1,14 @@ package IPC::Open2; + +use strict; +use vars qw($VERSION @ISA @EXPORT); + require 5.000; require Exporter; -use Carp; + +$VERSION = 1.01; +@ISA = qw(Exporter); +@EXPORT = qw(open2); =head1 NAME @@ -22,6 +29,13 @@ when you try open(HANDLE, "|cmd args|"); +If $rdr is a string (that is, a bareword filehandle rather than a glob +or a reference) and it begins with ">&", then the child will send output +directly to that file handle. If $wtr is a string that begins with +"<&", then WTR will be closed in the parent, and the child will read +from it directly. In both cases, there will be a dup(2) instead of a +pipe(2) made. + open2() returns the process ID of the child process. It doesn't return on failure: it just raises an exception matching C</^open2:/>. @@ -44,13 +58,11 @@ read and write a line from it. =head1 SEE ALSO -See L<open3> for an alternative that handles STDERR as well. +See L<IPC::Open3> for an alternative that handles STDERR as well. This +function is really just a wrapper around open3(). =cut -@ISA = qw(Exporter); -@EXPORT = qw(open2); - # &open2: tom christiansen, <tchrist@convex.com> # # usage: $pid = open2('rdr', 'wtr', 'some cmd and args'); @@ -67,41 +79,15 @@ See L<open3> for an alternative that handles STDERR as well. # # abort program if # rdr or wtr are null -# pipe or fork or exec fails +# a system call fails -$fh = 'FHOPEN000'; # package static in case called more than once +require IPC::Open3; sub open2 { - local($kidpid); - local($dad_rdr, $dad_wtr, @cmd) = @_; - - $dad_rdr ne '' || croak "open2: rdr should not be null"; - $dad_wtr ne '' || croak "open2: wtr should not be null"; - - # force unqualified filehandles into callers' package - local($package) = caller; - $dad_rdr =~ s/^([^']+$)/$package'$1/ unless ref $dad_rdr; - $dad_wtr =~ s/^([^']+$)/$package'$1/ unless ref $dad_wtr; - - local($kid_rdr) = ++$fh; - local($kid_wtr) = ++$fh; - - pipe($dad_rdr, $kid_wtr) || croak "open2: pipe 1 failed: $!"; - pipe($kid_rdr, $dad_wtr) || croak "open2: pipe 2 failed: $!"; - - if (($kidpid = fork) < 0) { - croak "open2: fork failed: $!"; - } elsif ($kidpid == 0) { - close $dad_rdr; close $dad_wtr; - open(STDIN, "<&$kid_rdr"); - open(STDOUT, ">&$kid_wtr"); - warn "execing @cmd\n" if $debug; - exec @cmd - or croak "open2: exec of @cmd failed"; - } - close $kid_rdr; close $kid_wtr; - select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe - $kidpid; + my ($read, $write, @cmd) = @_; + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + return IPC::Open3::_open3('open2', scalar caller, + $write, $read, '>&STDERR', @cmd); } -1; # so require is happy +1 diff --git a/lib/IPC/Open3.pm b/lib/IPC/Open3.pm index d416ae7886..5d8545889e 100644 --- a/lib/IPC/Open3.pm +++ b/lib/IPC/Open3.pm @@ -1,7 +1,18 @@ 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.01; +@ISA = qw(Exporter); +@EXPORT = qw(open3); =head1 NAME @@ -9,7 +20,7 @@ IPC::Open3, open3 - open a process for reading, writing, and error handling =head1 SYNOPSIS - $pid = open3(\*WTRFH, \*RDRFH, \*ERRFH + $pid = open3(\*WTRFH, \*RDRFH, \*ERRFH 'some cmd and args', 'optarg', ...); =head1 DESCRIPTION @@ -29,12 +40,28 @@ 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. -All caveats from open2() continue to apply. See L<open2> for details. +open3() returns the process ID of the child process. It doesn't return on +failure: it just raises an exception matching C</^open3:/>. -=cut +=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. -@ISA = qw(Exporter); -@EXPORT = qw(open3); +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> @@ -48,7 +75,7 @@ All caveats from open2() continue to apply. See L<open2> for details. # 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 0 on failure. +# of child (or dies on failure). # if wtr begins with '<&', then wtr will be closed in the parent, and @@ -64,17 +91,41 @@ All caveats from open2() continue to apply. See L<open2> for details. # # abort program if # rdr or wtr are null -# pipe or fork or exec fails +# a system call fails -$fh = 'FHOPEN000'; # package static in case called more than once +$Fh = 'FHOPEN000'; # package static in case called more than once +$Me = 'open3 (bug)'; # you should never see this, it's always localized -sub open3 { - my($kidpid); - my($dad_wtr, $dad_rdr, $dad_err, @cmd) = @_; - my($dup_wtr, $dup_rdr, $dup_err); +# 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. - $dad_wtr || croak "open3: wtr should not be null"; - $dad_rdr || croak "open3: rdr should not be null"; +sub xopen { + open $_[0], $_[1] or croak "$Me: open($_[0], $_[1]) failed: $!"; +} + +sub xclose { + close $_[0] or croak "$Me: close($_[0]) failed: $!"; +} + +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/^[<>]&//); @@ -82,28 +133,29 @@ sub open3 { $dup_err = ($dad_err =~ s/^[<>]&//); # force unqualified filehandles into callers' package - my($package) = caller; - $dad_wtr =~ s/^([^:]+$)/$package\:\:$1/ unless ref $dad_wtr; - $dad_rdr =~ s/^([^:]+$)/$package\:\:$1/ unless ref $dad_rdr; - $dad_err =~ s/^([^:]+$)/$package\:\:$1/ unless ref $dad_err; - - my($kid_rdr) = ++$fh; - my($kid_wtr) = ++$fh; - my($kid_err) = ++$fh; - - if (!$dup_wtr) { - pipe($kid_rdr, $dad_wtr) || croak "open3: pipe 1 (stdin) failed: $!"; - } - if (!$dup_rdr) { - pipe($dad_rdr, $kid_wtr) || croak "open3: pipe 2 (stdout) failed: $!"; - } - if ($dad_err ne $dad_rdr && !$dup_err) { - pipe($dad_err, $kid_err) || croak "open3: pipe 3 (stderr) failed: $!"; - } + $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 = xfork; + if ($kidpid == 0) { + # 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 (($kidpid = fork) < 0) { - croak "open3: fork failed: $!"; - } elsif ($kidpid == 0) { if ($dup_wtr) { open(STDIN, "<&$dad_wtr") if (fileno(STDIN) != fileno($dad_wtr)); } else { @@ -132,13 +184,19 @@ sub open3 { or croak "open3: exec of @cmd failed"; } - close $kid_rdr; close $kid_wtr; close $kid_err; - if ($dup_wtr) { - close($dad_wtr); - } + 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 { + return _open3 'open3', scalar caller, @_ +} 1; # so require is happy |