From: Roderick Schertler Date: Thu, 19 Dec 1996 03:19:54 +0000 (-0500) Subject: Re: Open3.pm tries to close unopened file handle X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=982b4e8fc47473059e209787b589853f4c8f8f9e;p=p5sagit%2Fp5-mst-13.2.git Re: Open3.pm tries to close unopened file handle # This patch contains two new test files. touch t/lib/open3.t t/lib/open2.t chmod +x t/lib/open3.t t/lib/open2.t exit 0 Here's the open2.pl/open3.pl/Open2.pl/Open3.pl overhaul I was talking about. - open2.pl and open3.pl become wrappers around the IPC:: versions. - open2() becomes a wrapper around open3() - New test files open2.t and open3.t - Bug fixes: - open3(WRITE, READ, '>&STDOUT') now works - spurious warnings from close() when dup()ping squelched - failed fork() wasn't detected properly - remaining system calls checked for success - package qualified bareword filehandles didn't used to work in open2() if they were qualified with :: and in open3() if they were qualified with ' p5p-msgid: --- diff --git a/MANIFEST b/MANIFEST index ce57721..210d81d 100644 --- a/MANIFEST +++ b/MANIFEST @@ -612,6 +612,8 @@ t/lib/io_xs.t See if XSUB methods from IO work t/lib/ndbm.t See if NDBM_File works t/lib/odbm.t See if ODBM_File works t/lib/opcode.t See if Opcode works +t/lib/open2.t See if IPC::Open3 works +t/lib/open3.t See if IPC::Open2 works t/lib/ops.t See if Opcode works t/lib/parsewords.t See if Text::ParseWords works t/lib/posix.t See if POSIX works diff --git a/lib/IPC/Open2.pm b/lib/IPC/Open2.pm index 35bb0d1..cfd15a8 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. @@ -44,13 +58,11 @@ read and write a line from it. =head1 SEE ALSO -See L for an alternative that handles STDERR as well. +See L 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, # # usage: $pid = open2('rdr', 'wtr', 'some cmd and args'); @@ -67,41 +79,15 @@ See L 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 d416ae7..5d85458 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 for details. +open3() returns the process ID of the child process. It doesn't return on +failure: it just raises an exception matching C. -=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, both writing to it +and reading from it. This is presumably safe because you "know" that +commands like B will read a line at a time and output a line at a +time. Programs like B 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 and continually read and write a line from it. + +=cut # &open3: Marc Horowitz # derived mostly from &open2 by tom christiansen, @@ -48,7 +75,7 @@ All caveats from open2() continue to apply. See L 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 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 diff --git a/lib/open2.pl b/lib/open2.pl index 7d3b970..8cf08c2 100644 --- a/lib/open2.pl +++ b/lib/open2.pl @@ -1,54 +1,12 @@ -# &open2: tom christiansen, +# This is a compatibility interface to IPC::Open2. New programs should +# do # -# usage: $pid = &open2('rdr', 'wtr', 'some cmd and args'); -# or $pid = &open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args'); +# use IPC::Open2; # -# spawn the given $cmd and connect $rdr for -# reading and $wtr for writing. return pid -# of child, or 0 on failure. -# -# 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 -# pipe or fork or exec fails - -package open2; -$fh = 'FHOPEN000'; # package static in case called more than once - -sub main'open2 { - local($kidpid); - local($dad_rdr, $dad_wtr, @cmd) = @_; - - $dad_rdr ne '' || die "open2: rdr should not be null"; - $dad_wtr ne '' || die "open2: wtr should not be null"; - - # force unqualified filehandles into callers' package - local($package) = caller; - $dad_rdr =~ s/^([^']+$)/$package'$1/; - $dad_wtr =~ s/^([^']+$)/$package'$1/; - - local($kid_rdr) = ++$fh; - local($kid_wtr) = ++$fh; - - pipe($dad_rdr, $kid_wtr) || die "open2: pipe 1 failed: $!"; - pipe($kid_rdr, $dad_wtr) || die "open2: pipe 2 failed: $!"; +# instead of +# +# require 'open2.pl'; - if (($kidpid = fork) < 0) { - die "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; - die "open2: exec of @cmd failed"; - } - close $kid_rdr; close $kid_wtr; - select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe - $kidpid; -} -1; # so require is happy +package main; +use IPC::Open2 'open2'; +1 diff --git a/lib/open3.pl b/lib/open3.pl index 8b3917a..7fcc931 100644 --- a/lib/open3.pl +++ b/lib/open3.pl @@ -1,106 +1,12 @@ -# &open3: Marc Horowitz -# derived mostly from &open2 by tom christiansen, +# This is a compatibility interface to IPC::Open3. New programs should +# do # -# $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $ +# use IPC::Open3; # -# usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...); +# instead of # -# 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 0 on failure. +# require 'open3.pl'; - -# 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 -# pipe or fork or exec fails - -package open3; - -$fh = 'FHOPEN000'; # package static in case called more than once - -sub main'open3 { - local($kidpid); - local($dad_wtr, $dad_rdr, $dad_err, @cmd) = @_; - local($dup_wtr, $dup_rdr, $dup_err); - - $dad_wtr || die "open3: wtr should not be null"; - $dad_rdr || die "open3: 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 - local($package) = caller; - $dad_wtr =~ s/^([^']+$)/$package'$1/; - $dad_rdr =~ s/^([^']+$)/$package'$1/; - $dad_err =~ s/^([^']+$)/$package'$1/; - - local($kid_rdr) = ++$fh; - local($kid_wtr) = ++$fh; - local($kid_err) = ++$fh; - - if (!$dup_wtr) { - pipe($kid_rdr, $dad_wtr) || die "open3: pipe 1 (stdin) failed: $!"; - } - if (!$dup_rdr) { - pipe($dad_rdr, $kid_wtr) || die "open3: pipe 2 (stdout) failed: $!"; - } - if ($dad_err ne $dad_rdr && !$dup_err) { - pipe($dad_err, $kid_err) || die "open3: pipe 3 (stderr) failed: $!"; - } - - if (($kidpid = fork) < 0) { - die "open2: fork failed: $!"; - } elsif ($kidpid == 0) { - if ($dup_wtr) { - open(STDIN, "<&$dad_wtr") if (fileno(STDIN) != fileno($dad_wtr)); - } else { - close($dad_wtr); - open(STDIN, "<&$kid_rdr"); - } - if ($dup_rdr) { - open(STDOUT, ">&$dad_rdr") if (fileno(STDOUT) != fileno($dad_rdr)); - } else { - close($dad_rdr); - open(STDOUT, ">&$kid_wtr"); - } - if ($dad_rdr ne $dad_err) { - if ($dup_err) { - open(STDERR, ">&$dad_err") - if (fileno(STDERR) != fileno($dad_err)); - } else { - close($dad_err); - open(STDERR, ">&$kid_err"); - } - } else { - open(STDERR, ">&STDOUT") if (fileno(STDERR) != fileno(STDOUT)); - } - local($")=(" "); - exec @cmd; - die "open2: exec of @cmd failed"; - } - - close $kid_rdr; close $kid_wtr; close $kid_err; - if ($dup_wtr) { - close($dad_wtr); - } - - select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe - $kidpid; -} -1; # so require is happy +package main; +use IPC::Open3 'open3'; +1 diff --git a/pod/perldiag.pod b/pod/perldiag.pod index bbd699f..d08c53a 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -635,7 +635,7 @@ Usually this is because you don't have read permission for the file. (W) You tried to say C, which is not supported. You can try any of several modules in the Perl library to do this, such as -"open2.pl". Alternately, direct the pipe's output to a file using "E", +IPC::Open2. Alternately, direct the pipe's output to a file using "E", and then read it in under a different file handle. =item Can't open error file %s as stderr diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 49b77f0..1148176 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -1754,8 +1754,8 @@ If the filename begins with "|", the filename is interpreted as a command to which output is to be piped, and if the filename ends with a "|", the filename is interpreted See L for more examples of this. as command which pipes input to us. (You may not have -a raw open() to a command that pipes both in I out, but see L, -L, and L for alternatives.) +a raw open() to a command that pipes both in I out, but see L, +L, and L for alternatives.) Opening '-' opens STDIN and opening 'E-' opens STDOUT. Open returns non-zero upon success, the undefined value otherwise. If the open @@ -2052,7 +2052,7 @@ unless you are very careful. In addition, note that Perl's pipes use stdio buffering, so you may need to set C<$|> to flush your WRITEHANDLE after each command, depending on the application. -See L, L, and L +See L, L, and L for examples of such things. =item pop ARRAY diff --git a/t/lib/open2.t b/t/lib/open2.t index e69de29..8dd786b 100755 --- a/t/lib/open2.t +++ b/t/lib/open2.t @@ -0,0 +1,39 @@ +#!./perl -w +use strict; + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + # make warnings fatal + $SIG{__WARN__} = sub { die @_ }; +} + +use IO::Handle; +use IPC::Open2; +#require 'open2.pl'; use subs 'open2'; + +sub ok { + my ($n, $result, $info) = @_; + if ($result) { + print "ok $n\n"; + } + else { + print "not ok $n\n"; + print "# $info\n" if $info; + } +} + +my ($pid, $reaped_pid); +STDOUT->autoflush; +STDERR->autoflush; + +print "1..7\n"; + +ok 1, $pid = open2 'READ', 'WRITE', $^X, '-e', 'print scalar '; +ok 2, print WRITE "hi kid\n"; +ok 3, eq "hi kid\n"; +ok 4, close(WRITE), $!; +ok 5, close(READ), $!; +$reaped_pid = waitpid $pid, 0; +ok 6, $reaped_pid == $pid, $reaped_pid; +ok 7, $? == 0, $?; diff --git a/t/lib/open3.t b/t/lib/open3.t index e69de29..a4a978e 100755 --- a/t/lib/open3.t +++ b/t/lib/open3.t @@ -0,0 +1,114 @@ +#!./perl -w +use strict; + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + # make warnings fatal + $SIG{__WARN__} = sub { die @_ }; +} + +use IO::Handle; +use IPC::Open3; +#require 'open3.pl'; use subs 'open3'; + +sub ok { + my ($n, $result, $info) = @_; + if ($result) { + print "ok $n\n"; + } + else { + print "not ok $n\n"; + print "# $info\n" if $info; + } +} + +my ($pid, $reaped_pid); +STDOUT->autoflush; +STDERR->autoflush; + +print "1..21\n"; + +# basic +ok 1, $pid = open3 'WRITE', 'READ', 'ERROR', $^X, '-e', <<'EOF'; + $| = 1; + print scalar ; + print STDERR "hi error\n"; +EOF +ok 2, print WRITE "hi kid\n"; +ok 3, eq "hi kid\n"; +ok 4, eq "hi error\n"; +ok 5, close(WRITE), $!; +ok 6, close(READ), $!; +ok 7, close(ERROR), $!; +$reaped_pid = waitpid $pid, 0; +ok 8, $reaped_pid == $pid, $reaped_pid; +ok 9, $? == 0, $?; + +# read and error together, both named +$pid = open3 'WRITE', 'READ', 'READ', $^X, '-e', <<'EOF'; + $| = 1; + print scalar ; + print STDERR scalar ; +EOF +print WRITE "ok 10\n"; +print scalar ; +print WRITE "ok 11\n"; +print scalar ; +waitpid $pid, 0; + +# read and error together, error empty +$pid = open3 'WRITE', 'READ', '', $^X, '-e', <<'EOF'; + $| = 1; + print scalar ; + print STDERR scalar ; +EOF +print WRITE "ok 12\n"; +print scalar ; +print WRITE "ok 13\n"; +print scalar ; +waitpid $pid, 0; + +# dup writer +ok 14, pipe PIPE_READ, PIPE_WRITE; +$pid = open3 '<&PIPE_READ', 'READ', '', + $^X, '-e', 'print scalar '; +close PIPE_READ; +print PIPE_WRITE "ok 15\n"; +close PIPE_WRITE; +print scalar ; +waitpid $pid, 0; + +# dup reader +$pid = open3 'WRITE', '>&STDOUT', 'ERROR', + $^X, '-e', 'print scalar '; +print WRITE "ok 16\n"; +waitpid $pid, 0; + +# dup error: This particular case, duping stderr onto the existing +# stdout but putting stdout somewhere else, is a good case because it +# used not to work. +$pid = open3 'WRITE', 'READ', '>&STDOUT', + $^X, '-e', 'print STDERR scalar '; +print WRITE "ok 17\n"; +waitpid $pid, 0; + +# dup reader and error together, both named +$pid = open3 'WRITE', '>&STDOUT', '>&STDOUT', $^X, '-e', <<'EOF'; + $| = 1; + print STDOUT scalar ; + print STDERR scalar ; +EOF +print WRITE "ok 18\n"; +print WRITE "ok 19\n"; +waitpid $pid, 0; + +# dup reader and error together, error empty +$pid = open3 'WRITE', '>&STDOUT', '', $^X, '-e', <<'EOF'; + $| = 1; + print STDOUT scalar ; + print STDERR scalar ; +EOF +print WRITE "ok 20\n"; +print WRITE "ok 21\n"; +waitpid $pid, 0;