diff options
-rw-r--r-- | ext/IPC-Open3/lib/IPC/Open3.pm | 8 | ||||
-rw-r--r-- | ext/IPC-Open3/t/IPC-Open3.t | 42 | ||||
-rw-r--r-- | pod/perldelta.pod | 7 |
3 files changed, 53 insertions, 4 deletions
diff --git a/ext/IPC-Open3/lib/IPC/Open3.pm b/ext/IPC-Open3/lib/IPC/Open3.pm index 7c7e9b532a..273f205480 100644 --- a/ext/IPC-Open3/lib/IPC/Open3.pm +++ b/ext/IPC-Open3/lib/IPC/Open3.pm @@ -9,7 +9,7 @@ require Exporter; use Carp; use Symbol qw(gensym qualify); -$VERSION = '1.18'; +$VERSION = '1.19'; @ISA = qw(Exporter); @EXPORT = qw(open3); @@ -412,7 +412,11 @@ sub spawn_with_handles { } else { $pid = eval { system 1, @_ }; # 1 == P_NOWAIT } - push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!" if !$pid || $pid < 0; + if($@) { + push @errs, "IO::Pipe: Can't spawn-NOWAIT: $@"; + } elsif(!$pid || $pid < 0) { + push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!"; + } } # Do this in reverse, so that STDERR is restored first: diff --git a/ext/IPC-Open3/t/IPC-Open3.t b/ext/IPC-Open3/t/IPC-Open3.t index fcaecef61c..25cfdfb6ae 100644 --- a/ext/IPC-Open3/t/IPC-Open3.t +++ b/ext/IPC-Open3/t/IPC-Open3.t @@ -14,7 +14,7 @@ BEGIN { } use strict; -use Test::More tests => 44; +use Test::More tests => 45; use IO::Handle; use IPC::Open3; @@ -165,6 +165,46 @@ $pid = eval { open3 'WRITE', '', 'ERROR', '/non/existent/program'; }; like($@, qr/^open3: Modification of a read-only value attempted at /, 'open3 faults read-only parameters correctly') or do {waitpid $pid, 0}; +package NoFetch; + +my $fetchcount = 1; + +sub TIESCALAR { + my $class = shift; + my $instance = shift || undef; + return bless \$instance => $class; +} + +sub FETCH { + my $cmd; #dont let "@args = @DB::args;" in Carp::caller_info fire this die + #fetchcount may need to be increased to 2 if this code is being stepped with + #a perl debugger + if($fetchcount == 1 && (caller(1))[3] ne 'Carp::caller_info') { + #Carp croak reports the errors as being in IPC-Open3.t, so it is + #unacceptable for testing where the FETCH failure occured, we dont want + #it failing in a $foo = $_[0]; #later# system($foo), where the failure + #is supposed to be triggered in the inner most syscall, aka system() + my ($package, $filename, $line, $subroutine) = caller(2); + + die("FETCH not allowed in ".((caller(1))[3])." in ".((caller(2))[3])."\n"); + } else { + $fetchcount++; + return tie($cmd, 'NoFetch'); + } +} + +package main; + +{ + my $cmd; + tie($cmd, 'NoFetch'); + + $pid = eval { open3 'WRITE', 'READ', 'ERROR', $cmd; }; + like($@, qr/^(?:open3: IO::Pipe: Can't spawn-NOWAIT: FETCH not allowed in \(eval\) (?x: + )in IPC::Open3::spawn_with_handles|FETCH not allowed in \(eval\) in IPC::Open3::_open3)/, + 'dieing inside Tied arg propagates correctly') or do {waitpid $pid, 0}; +} + foreach my $handle (qw (DUMMY STDIN STDOUT STDERR)) { local $::{$handle}; my $out = IO::Handle->new(); diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 68df77fbeb..78186032be 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -148,7 +148,12 @@ XXX =item * -L<XXX> has been upgraded from version A.xx to B.yy. +L<IPC::Open3> has been upgraded from version 1.18 to 1.19. + +If a Perl exception was thrown from inside this module, the exception +C<IPC::Open3> threw to the callers of C<open3> would have an irrelavent +message derived from C<$!> which was in an undefined state, instead of the +C<$@> message which triggers the failure path inside C<open3>. =back |