X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FIPC%2FOpen3.pm;h=95313fce3d95f8f3355c49b1b5248dd20edd8ee6;hb=fe98d82b2e4171a609025e7b159d7945efe2900c;hp=5bc757c3444b50568cfe89bf7cdaa20b2b5d1237;hpb=cb1a09d0194fed9b905df7b04a4bc031d354609d;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/IPC/Open3.pm b/lib/IPC/Open3.pm index 5bc757c..95313fc 100644 --- a/lib/IPC/Open3.pm +++ b/lib/IPC/Open3.pm @@ -1,7 +1,17 @@ package IPC::Open3; -require 5.001; + +use strict; +no strict 'refs'; # because users pass me bareword filehandles +our ($VERSION, @ISA, @EXPORT); + require Exporter; + use Carp; +use Symbol qw(gensym qualify); + +$VERSION = 1.02; +@ISA = qw(Exporter); +@EXPORT = qw(open3); =head1 NAME @@ -9,36 +19,102 @@ IPC::Open3, open3 - open a process for reading, writing, and error handling =head1 SYNOPSIS - $pid = open3(\*WTRFH, \*RDRFH, \*ERRFH + $pid = open3(\*CHLD_IN, \*CHLD_OUT, \*CHLD_ERR, + 'some cmd and args', 'optarg', ...); + + my($wtr, $rdr, $err); + $pid = open3($wtr, $rdr, $err, '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. +connects CHLD_OUT for reading from the child, CHLD_IN for writing to +the child, and CHLD_ERR for errors. If CHLD_ERR is false, or the +same file descriptor as CHLD_OUT, then STDOUT and STDERR of the child +are on the same filehandle. The CHLD_IN will have autoflush turned +on. + +If CHLD_IN begins with C<< <& >>, then CHLD_IN will be closed in the +parent, and the child will read from it directly. If CHLD_OUT or +CHLD_ERR begins with C<< >& >>, then the child will send output +directly to that filehandle. In both cases, there will be a dup(2) +instead of a pipe(2) made. + +If either reader or writer is the null string, this will be replaced +by an autogenerated filehandle. If so, you must pass a valid lvalue +in the parameter slot so it can be overwritten in the caller, or +an exception will be raised. + +The filehandles may also be integers, in which case they are understood +as file descriptors. + +open3() returns the process ID of the child process. It doesn't return on +failure: it just raises an exception matching C. However, +C failures in the child (such as no such file or permission denied), +are just reported to CHLD_ERR, as it is not possible to trap them. -If WTRFH begins with "<&", then WTRFH will be closed in the parent, and -the child will read from it directly. If RDRFH or ERRFH begins with -">&", 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 the child process dies for any reason, the next write to CHLD_IN is +likely to generate a SIGPIPE in the parent, which is fatal by default. +So you may wish to handle this signal. + +Note if you specify C<-> as the command, in an analogous fashion to +C the child process will just be the forked Perl +process rather than an external command. This feature isn't yet +supported on Win32 platforms. + +open3() does not wait for and reap the child process after it exits. +Except for short programs where it's acceptable to let the operating system +take care of this, you need to do this yourself. This is normally as +simple as calling C when you're done with the process. +Failing to do this can result in an accumulation of defunct or "zombie" +processes. See L for more information. 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. +writer, you'll have problems with blocking, which means you'll want +to use select() or the IO::Select, which means you'd best use +sysread() instead of readline() for normal stuff. -All caveats from open2() continue to apply. See L for details. +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. -=cut +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 and continually read and write a line from it. + +=head1 See Also + +=over 4 + +=item L + +Like Open3 but without STDERR catpure. + +=item L + +This is a CPAN module that has better error handling and more facilities +than Open3. + +=back -@ISA = qw(Exporter); -@EXPORT = qw(open3); +=head1 WARNING + +The order of arguments differs from that of open2(). + +=cut # &open3: Marc Horowitz # derived mostly from &open2 by tom christiansen, # fixed for 5.001 by Ulrich Kunitz +# ported to Win32 by Ron Schmidt, Merrill Lynch almost ended my career +# fixed for autovivving FHs, tchrist again +# allow fd numbers to be used, by Frank Tobin +# allow '-' as command (c.f. open "-|"), by Adam Spiers # # $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $ # @@ -48,7 +124,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,81 +140,232 @@ 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 +our $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. + +sub xopen { + open $_[0], $_[1] or croak "$Me: open($_[0], $_[1]) failed: $!"; +} + +sub xclose { + close $_[0] or croak "$Me: close($_[0]) failed: $!"; +} + +sub fh_is_fd { + return $_[0] =~ /\A=?(\d+)\z/; +} - $dad_wtr || croak "open3: wtr should not be null"; - $dad_rdr || croak "open3: rdr should not be null"; - $dad_err = $dad_rdr if ($dad_err eq ''); +sub xfileno { + return $1 if $_[0] =~ /\A=?(\d+)\z/; # deal with fh just being an fd + return fileno $_[0]; +} + +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); + + if (@cmd > 1 and $cmd[0] eq '-') { + croak "Arguments don't make sense when the command is '-'" + } + + # simulate autovivification of filehandles because + # it's too ugly to use @_ throughout to make perl do it for us + # tchrist 5-Mar-00 + + unless (eval { + $dad_wtr = $_[1] = gensym unless defined $dad_wtr && length $dad_wtr; + $dad_rdr = $_[2] = gensym unless defined $dad_rdr && length $dad_rdr; + 1; }) + { + # must strip crud for croak to add back, or looks ugly + $@ =~ s/(?<=value attempted) at .*//s; + croak "$Me: $@"; + } + + $dad_err ||= $dad_rdr; $dup_wtr = ($dad_wtr =~ s/^[<>]&//); $dup_rdr = ($dad_rdr =~ s/^[<>]&//); $dup_err = ($dad_err =~ s/^[<>]&//); - # force unqualified filehandles into callers' package - my($package) = caller; - $dad_wtr =~ s/^[^:]+$/$package\:\:$&/ unless ref $dad_wtr; - $dad_rdr =~ s/^[^:]+$/$package\:\:$&/ unless ref $dad_rdr; - $dad_err =~ s/^[^:]+$/$package\:\:$&/ unless ref $dad_err; + # force unqualified filehandles into caller's package + $dad_wtr = qualify $dad_wtr, $package unless fh_is_fd($dad_wtr); + $dad_rdr = qualify $dad_rdr, $package unless fh_is_fd($dad_rdr); + $dad_err = qualify $dad_err, $package unless fh_is_fd($dad_err); - my($kid_rdr) = ++$fh; - my($kid_wtr) = ++$fh; - my($kid_err) = ++$fh; + my $kid_rdr = gensym; + my $kid_wtr = gensym; + my $kid_err = gensym; - 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: $!"; - } + 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 + # A tie in the parent should not be allowed to cause problems. + untie *STDIN; + untie *STDOUT; + # 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 + && xfileno($dad_err) == fileno(STDOUT)) { + my $tmp = gensym; + xopen($tmp, ">&$dad_err"); + $dad_err = $tmp; + } - if (($kidpid = fork) < 0) { - croak "open2: fork failed: $!"; - } elsif ($kidpid == 0) { if ($dup_wtr) { - open(STDIN, "<&$dad_wtr") if (fileno(STDIN) != fileno($dad_wtr)); + xopen \*STDIN, "<&$dad_wtr" if fileno(STDIN) != xfileno($dad_wtr); } else { - close($dad_wtr); - open(STDIN, "<&$kid_rdr"); + xclose $dad_wtr; + xopen \*STDIN, "<&=" . fileno $kid_rdr; } if ($dup_rdr) { - open(STDOUT, ">&$dad_rdr") if (fileno(STDOUT) != fileno($dad_rdr)); + xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != xfileno($dad_rdr); } else { - close($dad_rdr); - open(STDOUT, ">&$kid_wtr"); + xclose $dad_rdr; + xopen \*STDOUT, ">&=" . fileno $kid_wtr; } if ($dad_rdr ne $dad_err) { if ($dup_err) { - open(STDERR, ">&$dad_err") - if (fileno(STDERR) != fileno($dad_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, ">&" . xfileno($dad_err) + if fileno(STDERR) != xfileno($dad_err); } else { - close($dad_err); - open(STDERR, ">&$kid_err"); + xclose $dad_err; + xopen \*STDERR, ">&=" . fileno $kid_err; } } else { - open(STDERR, ">&STDOUT") if (fileno(STDERR) != fileno(STDOUT)); + xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT); } + return 0 if ($cmd[0] eq '-'); local($")=(" "); - exec @cmd; - croak "open2: exec of @cmd failed"; - } + exec @cmd or do { + carp "$Me: exec of @cmd failed"; + eval { require POSIX; POSIX::_exit(255); }; + exit 255; + }; + } elsif ($do_spawn) { + # All the bookkeeping of coincidence between handles is + # handled in spawn_with_handles. - close $kid_rdr; close $kid_wtr; close $kid_err; - if ($dup_wtr) { - close($dad_wtr); + 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; } -1; # so require is happy +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