make system() return -1 and set $! if exec of child failed

	Message-ID: <19990709052113.A6201@monk.mps.ohio-state.edu>
	Subject: [PATCH 5.005_57] system()==-1 and $! from failing fork/exec

p4raw-id: //depot/perl@3679

10 files changed, 74 insertions, 5 deletions

diff --git a/doio.c b/doio.c
index 674bd7b1fb..b0c7a9e98c 100644
--- a/doio.c
+++ b/doio.c
@@ -1049,6 +1049,12 @@ Perl_my_lstat(pTHX)
 bool
 Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp)
 {
+    return do_aexec5(really, mark, sp, 0, 0);
+}
+
+bool
+do_aexec5(SV *really, register SV **mark, register SV **sp, int fd, int do_report)
+{
     register char **a;
     char *tmps;
     STRLEN n_a;
@@ -1073,6 +1079,12 @@ Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp)
 	if (ckWARN(WARN_EXEC))
 	    Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s", 
 		PL_Argv[0], Strerror(errno));
+	if (do_report) {
+	    int e = errno;
+
+	    PerlLIO_write(fd, (void*)&e, sizeof(int));
+	    PerlLIO_close(fd);
+	}
     }
     do_execfree();
     return FALSE;
diff --git a/embed.h b/embed.h
index dfd37d0c4a..7789679fa7 100644
--- a/embed.h
+++ b/embed.h
@@ -102,6 +102,7 @@
 #define die_where		Perl_die_where
 #define dounwind		Perl_dounwind
 #define do_aexec		Perl_do_aexec
+#define do_aexec5		Perl_do_aexec5
 #define do_binmode		Perl_do_binmode
 #define do_chop			Perl_do_chop
 #define do_close		Perl_do_close
@@ -1422,6 +1423,7 @@
 #define die_where(a,b)		Perl_die_where(aTHX_ a,b)
 #define dounwind(a)		Perl_dounwind(aTHX_ a)
 #define do_aexec(a,b,c)		Perl_do_aexec(aTHX_ a,b,c)
+#define do_aexec5(a,b,c,d,e)	Perl_do_aexec5(aTHX_ a,b,c,d,e)
 #define do_binmode(a,b,c)	Perl_do_binmode(aTHX_ a,b,c)
 #define do_chop(a,b)		Perl_do_chop(aTHX_ a,b)
 #define do_close(a,b)		Perl_do_close(aTHX_ a,b)
@@ -2829,6 +2831,8 @@
 #define dounwind		Perl_dounwind
 #define Perl_do_aexec		CPerlObj::Perl_do_aexec
 #define do_aexec		Perl_do_aexec
+#define Perl_do_aexec5		CPerlObj::Perl_do_aexec5
+#define do_aexec5		Perl_do_aexec5
 #define Perl_do_binmode		CPerlObj::Perl_do_binmode
 #define do_binmode		Perl_do_binmode
 #define Perl_do_chop		CPerlObj::Perl_do_chop
diff --git a/embed.pl b/embed.pl
index 927fb02f4c..1af25adc21 100755
--- a/embed.pl
+++ b/embed.pl
@@ -1081,6 +1081,7 @@ p	|OP*	|vdie		|const char* pat|va_list* args
 p	|OP*	|die_where	|char* message|STRLEN msglen
 p	|void	|dounwind	|I32 cxix
 p	|bool	|do_aexec	|SV* really|SV** mark|SV** sp
+p	|bool	|do_aexec5	|SV* really|SV** mark|SV** sp|int fd|int flag
 p	|int	|do_binmode	|PerlIO *fp|int iotype|int flag
 p	|void	|do_chop	|SV* asv|SV* sv
 p	|bool	|do_close	|GV* gv|bool not_implicit
diff --git a/global.sym b/global.sym
index 06c71da103..8a3e7256ae 100644
--- a/global.sym
+++ b/global.sym
@@ -86,6 +86,7 @@ Perl_vdie
 Perl_die_where
 Perl_dounwind
 Perl_do_aexec
+Perl_do_aexec5
 Perl_do_binmode
 Perl_do_chop
 Perl_do_close
diff --git a/objXSUB.h b/objXSUB.h
index 43e29f4bbb..9728482089 100644
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -1147,6 +1147,10 @@
 #define Perl_do_aexec		pPerl->Perl_do_aexec
 #undef  do_aexec
 #define do_aexec		Perl_do_aexec
+#undef  Perl_do_aexec5
+#define Perl_do_aexec5		pPerl->Perl_do_aexec5
+#undef  do_aexec5
+#define do_aexec5		Perl_do_aexec5
 #undef  Perl_do_binmode
 #define Perl_do_binmode		pPerl->Perl_do_binmode
 #undef  do_binmode
diff --git a/perlapi.c b/perlapi.c
index d3ebc9b3d0..037ad3d77a 100755
--- a/perlapi.c
+++ b/perlapi.c
@@ -682,6 +682,13 @@ Perl_do_aexec(pTHXo_ SV* really, SV** mark, SV** sp)
     return ((CPerlObj*)pPerl)->Perl_do_aexec(really, mark, sp);
 }
 
+#undef  Perl_do_aexec5
+bool
+Perl_do_aexec5(pTHXo_ SV* really, SV** mark, SV** sp, int fd, int flag)
+{
+    return ((CPerlObj*)pPerl)->Perl_do_aexec5(really, mark, sp, fd, flag);
+}
+
 #undef  Perl_do_binmode
 int
 Perl_do_binmode(pTHXo_ PerlIO *fp, int iotype, int flag)
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index e7fdc78ad2..921b66f642 100644
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -4377,7 +4377,8 @@ The return value is the exit status of the program as
 returned by the C<wait> call.  To get the actual exit value divide by
 256.  See also L</exec>.  This is I<not> what you want to use to capture
 the output from a command, for that you should use merely backticks or
-C<qx//>, as described in L<perlop/"`STRING`">.
+C<qx//>, as described in L<perlop/"`STRING`">.  Return value of -1
+indicates a failure to start the program (inspect $! for the reason).
 
 Like C<exec>, C<system> allows you to lie to a program about its name if
 you use the C<system PROGRAM LIST> syntax.  Again, see L</exec>.
diff --git a/pp_sys.c b/pp_sys.c
index b216b629ed..cbd5764a31 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -3577,6 +3577,8 @@ PP(pp_system)
     int status;
     Sigsave_t ihand,qhand;     /* place to save signals during system() */
     STRLEN n_a;
+    I32 did_pipes = 0;
+    int pp[2];
 
     if (SP - MARK == 1) {
 	if (PL_tainting) {
@@ -3587,16 +3589,24 @@ PP(pp_system)
     }
     PERL_FLUSHALL_FOR_CHILD;
 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
+    if (PerlProc_pipe(pp) >= 0)
+	did_pipes = 1;
     while ((childpid = vfork()) == -1) {
 	if (errno != EAGAIN) {
 	    value = -1;
 	    SP = ORIGMARK;
 	    PUSHi(value);
+	    if (did_pipes) {
+		PerlLIO_close(pp[0]);
+		PerlLIO_close(pp[1]);
+	    }
 	    RETURN;
 	}
 	sleep(5);
     }
     if (childpid > 0) {
+	if (did_pipes)
+	    PerlLIO_close(pp[1]);
 	rsignal_save(SIGINT, SIG_IGN, &ihand);
 	rsignal_save(SIGQUIT, SIG_IGN, &qhand);
 	do {
@@ -3607,17 +3617,43 @@ PP(pp_system)
 	STATUS_NATIVE_SET(result == -1 ? -1 : status);
 	do_execfree();	/* free any memory child malloced on vfork */
 	SP = ORIGMARK;
+	if (did_pipes) {
+	    int errkid;
+	    int n = 0, n1;
+
+	    while (n < sizeof(int)) {
+		n1 = PerlLIO_read(pp[0],
+				  (void*)(((char*)&errkid)+n),
+				  (sizeof(int)) - n);
+		if (n1 <= 0)
+		    break;
+		n += n1;
+	    }
+	    PerlLIO_close(pp[0]);
+	    if (n) {			/* Error */
+		if (n != sizeof(int))
+		    Perl_croak(aTHX_ "panic: kid popen errno read");
+		errno = errkid;		/* Propagate errno from kid */
+		STATUS_CURRENT = -1;
+	    }
+	}
 	PUSHi(STATUS_CURRENT);
 	RETURN;
     }
+    if (did_pipes) {
+	PerlLIO_close(pp[0]);
+#if defined(HAS_FCNTL) && defined(F_SETFD)
+	fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+#endif
+    }
     if (PL_op->op_flags & OPf_STACKED) {
 	SV *really = *++MARK;
-	value = (I32)do_aexec(really, MARK, SP);
+	value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
     }
     else if (SP - MARK != 1)
-	value = (I32)do_aexec(Nullsv, MARK, SP);
+	value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
     else {
-	value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
+	value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
     }
     PerlProc__exit(-1);
 #else /* ! FORK or VMS or OS/2 */
diff --git a/proto.h b/proto.h
index fe399f0bcb..e4a9db8b93 100644
--- a/proto.h
+++ b/proto.h
@@ -95,6 +95,7 @@ VIRTUAL OP*	Perl_vdie(pTHX_ const char* pat, va_list* args);
 VIRTUAL OP*	Perl_die_where(pTHX_ char* message, STRLEN msglen);
 VIRTUAL void	Perl_dounwind(pTHX_ I32 cxix);
 VIRTUAL bool	Perl_do_aexec(pTHX_ SV* really, SV** mark, SV** sp);
+VIRTUAL bool	Perl_do_aexec5(pTHX_ SV* really, SV** mark, SV** sp, int fd, int flag);
 VIRTUAL int	Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int flag);
 VIRTUAL void	Perl_do_chop(pTHX_ SV* asv, SV* sv);
 VIRTUAL bool	Perl_do_close(pTHX_ GV* gv, bool not_implicit);
diff --git a/t/op/exec.t b/t/op/exec.t
index 5cf7386c93..99af53b29d 100755
--- a/t/op/exec.t
+++ b/t/op/exec.t
@@ -25,7 +25,9 @@ if (system "true") {print "not ok 4\n";} else {print "ok 4\n";}
 if ((system "/bin/sh -c 'exit 1'") != 256) { print "not "; }
 print "ok 5\n";
 
-if ((system "lskdfj") == 255 << 8) {print "ok 6\n";} else {print "not ok 6\n";}
+$rc = system "lskdfj";
+if ($rc == 255 << 8 or $rc == -1 and ($! == 2 or $! =~ /\bno\b.*\bfile/i))
+ {print "ok 6\n";} else {print "not ok 6\n";}
 
 unless (exec "lskdjfalksdjfdjfkls") {print "ok 7\n";} else {print "not ok 7\n";}