dont report a $@ exception with uninitialized $!'s message in IPC::Open3

Commit a24d8dfd08 "Make IPC::Open3 work without fork()" from 5.003 created
an eval block, and if that eval block threw an exception, instead of
propagating $@, the code propagated $!, even though no system call was done
and $! is effectivly unintialized data. In one case for me, a taint
exception inside system was turned into open3() throwing an exception
about "Inappropriate I/O control operation" or "Bad file descriptor", which
had nothing to do with the real fault which was a Perl C level croak with
the message "Insecure $ENV{PATH} while running with -T switch at ..."
which was called as Perl_pp_system->Perl_taint_env->Perl_taint_proper->
Perl_croak->Perl_vcroak. This patch does not try to fix the ambiguity of
the error messages between the !DO_SPAWN and IO::Pipe
branches/implementations of _open3.

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