Add error checks after execing PL_cshname or PL_sh_path

From: "Jan Dubois" <jand@activestate.com>
Message-ID: <002301c68a85$21aa7320$d045a8c0@candy>

p4raw-id: //depot/perl@28376

4 files changed, 33 insertions, 17 deletions

diff --git a/doio.c b/doio.c
index f5f59a3898..41f026fc9c 100644
--- a/doio.c
+++ b/doio.c
@@ -1396,6 +1396,19 @@ Perl_my_lstat(pTHX)
     return PL_laststatval;
 }
 
+static void
+S_exec_failed(pTHX_ const char *cmd, int fd, int do_report)
+{
+    const int e = errno;
+    if (ckWARN(WARN_EXEC))
+	Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
+		    cmd, Strerror(e));
+    if (do_report) {
+	PerlLIO_write(fd, (void*)&e, sizeof(int));
+	PerlLIO_close(fd);
+    }
+}
+
 bool
 Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp,
 	       int fd, int do_report)
@@ -1428,15 +1441,7 @@ Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp,
 	else
 	    PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
 	PERL_FPU_POST_EXEC
-	if (ckWARN(WARN_EXEC))
-	    Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
-		(really ? tmps : PL_Argv[0]), Strerror(errno));
-	if (do_report) {
-	    const int e = errno;
-
-	    PerlLIO_write(fd, (void*)&e, sizeof(int));
-	    PerlLIO_close(fd);
-	}
+ 	S_exec_failed(aTHX_ (really ? tmps : PL_Argv[0]), fd, do_report);
     }
     do_execfree();
 #endif
@@ -1508,6 +1513,7 @@ Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
 		  PerlProc_execl(PL_cshname, "csh", flags, ncmd, NULL);
 		  PERL_FPU_POST_EXEC
 		  *s = '\'';
+ 		  S_exec_failed(aTHX_ PL_cshname, fd, do_report);
 		  Safefree(cmd);
 		  return FALSE;
 	      }
@@ -1555,6 +1561,7 @@ Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
 	    PERL_FPU_PRE_EXEC
 	    PerlProc_execl(PL_sh_path, "sh", "-c", cmd, NULL);
 	    PERL_FPU_POST_EXEC
+ 	    S_exec_failed(aTHX_ PL_sh_path, fd, do_report);
 	    Safefree(cmd);
 	    return FALSE;
 	}
@@ -1582,14 +1589,7 @@ Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
 	    do_execfree();
 	    goto doshell;
 	}
-	if (ckWARN(WARN_EXEC))
-	    Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s",
-		PL_Argv[0], Strerror(errno));
-	if (do_report) {
-	    const int e = errno;
-	    PerlLIO_write(fd, (const void*)&e, sizeof(int));
-	    PerlLIO_close(fd);
-	}
+ 	S_exec_failed(aTHX_ PL_Argv[0], fd, do_report);
     }
     do_execfree();
     Safefree(cmd);
diff --git a/embed.fnc b/embed.fnc
index 1c4fff1a07..3212583c4f 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -206,6 +206,9 @@ Ap	|int	|do_spawn_nowait|NN char* cmd
 p	|bool	|do_exec3	|NN const char* cmd|int fd|int do_report
 #endif
 p	|void	|do_execfree
+#ifdef PERL_IN_DOIO_C
+s	|void	|exec_failed	|const char *cmd|int fd|int do_report
+#endif
 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
 p	|I32	|do_ipcctl	|I32 optype|NN SV** mark|NN SV** sp
 p	|I32	|do_ipcget	|I32 optype|NN SV** mark|NN SV** sp
diff --git a/embed.h b/embed.h
index 778baac9d7..2885e22b7d 100644
--- a/embed.h
+++ b/embed.h
@@ -188,6 +188,11 @@
 #ifdef PERL_CORE
 #define do_execfree		Perl_do_execfree
 #endif
+#ifdef PERL_IN_DOIO_C
+#ifdef PERL_CORE
+#define exec_failed		S_exec_failed
+#endif
+#endif
 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
 #ifdef PERL_CORE
 #define do_ipcctl		Perl_do_ipcctl
@@ -2363,6 +2368,11 @@
 #ifdef PERL_CORE
 #define do_execfree()		Perl_do_execfree(aTHX)
 #endif
+#ifdef PERL_IN_DOIO_C
+#ifdef PERL_CORE
+#define exec_failed(a,b,c)	S_exec_failed(aTHX_ a,b,c)
+#endif
+#endif
 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
 #ifdef PERL_CORE
 #define do_ipcctl(a,b,c)	Perl_do_ipcctl(aTHX_ a,b,c)
diff --git a/proto.h b/proto.h
index da4a1531cf..aad0de618d 100644
--- a/proto.h
+++ b/proto.h
@@ -441,6 +441,9 @@ PERL_CALLCONV bool	Perl_do_exec3(pTHX_ const char* cmd, int fd, int do_report)
 
 #endif
 PERL_CALLCONV void	Perl_do_execfree(pTHX);
+#ifdef PERL_IN_DOIO_C
+STATIC void	S_exec_failed(pTHX_ const char *cmd, int fd, int do_report);
+#endif
 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
 PERL_CALLCONV I32	Perl_do_ipcctl(pTHX_ I32 optype, SV** mark, SV** sp)
 			__attribute__nonnull__(pTHX_2)