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

diff --git a/doio.c b/doio.c
index 674bd7b..b0c7a9e 100644 (file)
--- 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 dfd37d0..7789679 100644 (file)
--- 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 927fb02..1af25ad 100755 (executable)
--- 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 06c71da..8a3e725 100644 (file)
--- 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 43e29f4..9728482 100644 (file)
--- 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 d3ebc9b..037ad3d 100755 (executable)
--- 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 e7fdc78..921b66f 100644 (file)
--- 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 b216b62..cbd5764 100644 (file)
--- 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 fe399f0..e4a9db8 100644 (file)
--- 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 5cf7386..99af53b 100755 (executable)
--- 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";}