Make perl fork()-safe (in a slightly limited way) even on

platforms that don't have pthread_atfork() (extension of
the fix in change#11151).

Note that this will not help extensions that call fork()
directly in C, or that link to libraries that call fork()
directly.  Such cases must be fixed to either call
PerlProc_fork(), or call atfork_lock() in parent before the
calling the function that forks and call atfork_unlock()
in both parent and child immediately after the fork().
(There are no worries if C code calls exec() in the child
immediately after a fork().  Only cases where the child
calls perl's API functions (including New()) after the
fork() are problematic.)

This change also eliminates the use of vfork() from perl,
since all such uses were violating the severe restrictions
on modifying the state of the process between the vfork()
and the exec().

This is a modified version of patches suggested by Abhijit
Menon-Sen and Richard Soderberg.

p4raw-link: @11151 on //depot/perl: 50dd6e574ff39b609595ddb16b2fe9f625a26f8c

p4raw-id: //depot/perl@11423

12 files changed, 122 insertions, 55 deletions

diff --git a/embed.h b/embed.h
index f6176db259..9093f9bd0f 100644
--- a/embed.h
+++ b/embed.h
@@ -430,6 +430,9 @@
 #define my_exit			Perl_my_exit
 #define my_failure_exit		Perl_my_failure_exit
 #define my_fflush_all		Perl_my_fflush_all
+#define my_fork			Perl_my_fork
+#define atfork_lock		Perl_atfork_lock
+#define atfork_unlock		Perl_atfork_unlock
 #define my_lstat		Perl_my_lstat
 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
 #define my_memcmp		Perl_my_memcmp
@@ -1941,6 +1944,9 @@
 #define my_exit(a)		Perl_my_exit(aTHX_ a)
 #define my_failure_exit()	Perl_my_failure_exit(aTHX)
 #define my_fflush_all()		Perl_my_fflush_all(aTHX)
+#define my_fork			Perl_my_fork
+#define atfork_lock		Perl_atfork_lock
+#define atfork_unlock		Perl_atfork_unlock
 #define my_lstat()		Perl_my_lstat(aTHX)
 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
 #define my_memcmp		Perl_my_memcmp
@@ -3806,6 +3812,12 @@
 #define my_failure_exit		Perl_my_failure_exit
 #define Perl_my_fflush_all	CPerlObj::Perl_my_fflush_all
 #define my_fflush_all		Perl_my_fflush_all
+#define Perl_my_fork		CPerlObj::Perl_my_fork
+#define my_fork			Perl_my_fork
+#define Perl_atfork_lock	CPerlObj::Perl_atfork_lock
+#define atfork_lock		Perl_atfork_lock
+#define Perl_atfork_unlock	CPerlObj::Perl_atfork_unlock
+#define atfork_unlock		Perl_atfork_unlock
 #define Perl_my_lstat		CPerlObj::Perl_my_lstat
 #define my_lstat		Perl_my_lstat
 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
diff --git a/embed.pl b/embed.pl
index f125ef0a49..2e473b6065 100755
--- a/embed.pl
+++ b/embed.pl
@@ -1769,6 +1769,9 @@ Anp	|char*	|my_bzero	|char* loc|I32 len
 Apr	|void	|my_exit	|U32 status
 Apr	|void	|my_failure_exit
 Ap	|I32	|my_fflush_all
+Anp	|Pid_t	|my_fork
+Anp	|void	|atfork_lock
+Anp	|void	|atfork_unlock
 Ap	|I32	|my_lstat
 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
 Anp	|I32	|my_memcmp	|const char* s1|const char* s2|I32 len
diff --git a/global.sym b/global.sym
index 53017399d7..73493c39cb 100644
--- a/global.sym
+++ b/global.sym
@@ -233,6 +233,9 @@ Perl_my_bzero
 Perl_my_exit
 Perl_my_failure_exit
 Perl_my_fflush_all
+Perl_my_fork
+Perl_atfork_lock
+Perl_atfork_unlock
 Perl_my_lstat
 Perl_my_memcmp
 Perl_my_memset
diff --git a/iperlsys.h b/iperlsys.h
index 081d8b2648..89b551b149 100644
--- a/iperlsys.h
+++ b/iperlsys.h
@@ -1074,7 +1074,7 @@ struct IPerlProcInfo
 #define PerlProc_setjmp(b, n)	Sigsetjmp((b), (n))
 #define PerlProc_longjmp(b, n)	Siglongjmp((b), (n))
 #define PerlProc_signal(n, h)	signal((n), (h))
-#define PerlProc_fork()		fork()
+#define PerlProc_fork()		my_fork()
 #define PerlProc_getpid()	getpid()
 
 #ifdef WIN32
diff --git a/miniperlmain.c b/miniperlmain.c
index 620fed78b2..2c924ebe2e 100644
--- a/miniperlmain.c
+++ b/miniperlmain.c
@@ -48,7 +48,16 @@ main(int argc, char **argv, char **env)
 
     PERL_SYS_INIT3(&argc,&argv,&env);
 
-#ifdef USE_ITHREADS
+#if defined(USE_THREADS) || defined(USE_ITHREADS)
+    /* XXX Ideally, this should really be happening in perl_alloc() or
+     * perl_construct() to keep libperl.a transparently fork()-safe.
+     * It is currently done here only because Apache/mod_perl have
+     * problems due to lack of a call to cancel pthread_atfork()
+     * handlers when shared objects that contain the handlers may
+     * be dlclose()d.  This forces applications that embed perl to
+     * call PTHREAD_ATFORK() explicitly, but if and only if it hasn't
+     * been called at least once before in the current process.
+     * --GSAR 2001-07-20 */
     PTHREAD_ATFORK(Perl_atfork_lock,
                    Perl_atfork_unlock,
                    Perl_atfork_unlock);
diff --git a/objXSUB.h b/objXSUB.h
index 43a10fa4fa..564bd9c4ab 100644
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -909,6 +909,18 @@
 #define Perl_my_fflush_all	pPerl->Perl_my_fflush_all
 #undef  my_fflush_all
 #define my_fflush_all		Perl_my_fflush_all
+#undef  Perl_my_fork
+#define Perl_my_fork		pPerl->Perl_my_fork
+#undef  my_fork
+#define my_fork			Perl_my_fork
+#undef  Perl_atfork_lock
+#define Perl_atfork_lock	pPerl->Perl_atfork_lock
+#undef  atfork_lock
+#define atfork_lock		Perl_atfork_lock
+#undef  Perl_atfork_unlock
+#define Perl_atfork_unlock	pPerl->Perl_atfork_unlock
+#undef  atfork_unlock
+#define atfork_unlock		Perl_atfork_unlock
 #undef  Perl_my_lstat
 #define Perl_my_lstat		pPerl->Perl_my_lstat
 #undef  my_lstat
diff --git a/perl.c b/perl.c
index 25cdcd6e4b..322960d211 100644
--- a/perl.c
+++ b/perl.c
@@ -58,29 +58,6 @@ static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
     } STMT_END
 #else
 #  if defined(USE_ITHREADS)
-
-/* this is called in parent before the fork() */
-void
-Perl_atfork_lock(void)
-{
-    /* locks must be held in locking order (if any) */
-#ifdef MYMALLOC
-    MUTEX_LOCK(&PL_malloc_mutex);
-#endif
-    OP_REFCNT_LOCK;
-}
-
-/* this is called in both parent and child after the fork() */
-void
-Perl_atfork_unlock(void)
-{
-    /* locks must be released in same order as in S_atfork_lock() */
-#ifdef MYMALLOC
-    MUTEX_UNLOCK(&PL_malloc_mutex);
-#endif
-    OP_REFCNT_UNLOCK;
-}
-
 #  define INIT_TLS_AND_INTERP \
     STMT_START {				\
 	if (!PL_curinterp) {			\
diff --git a/perlapi.c b/perlapi.c
index fb5c40725d..9b90154e72 100644
--- a/perlapi.c
+++ b/perlapi.c
@@ -1678,6 +1678,30 @@ Perl_my_fflush_all(pTHXo)
     return ((CPerlObj*)pPerl)->Perl_my_fflush_all();
 }
 
+#undef  Perl_my_fork
+Pid_t
+Perl_my_fork()
+{
+    dTHXo;
+    return ((CPerlObj*)pPerl)->Perl_my_fork();
+}
+
+#undef  Perl_atfork_lock
+void
+Perl_atfork_lock()
+{
+    dTHXo;
+    ((CPerlObj*)pPerl)->Perl_atfork_lock();
+}
+
+#undef  Perl_atfork_unlock
+void
+Perl_atfork_unlock()
+{
+    dTHXo;
+    ((CPerlObj*)pPerl)->Perl_atfork_unlock();
+}
+
 #undef  Perl_my_lstat
 I32
 Perl_my_lstat(pTHXo)
diff --git a/pp_sys.c b/pp_sys.c
index 6a74b115de..ac7ca20c2a 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -104,11 +104,6 @@ extern int h_errno;
 #  endif
 #endif
 
-/* Put this after #includes because fork and vfork prototypes may conflict. */
-#ifndef HAS_VFORK
-#   define vfork fork
-#endif
-
 #ifdef HAS_CHSIZE
 # ifdef my_chsize  /* Probably #defined to Perl_my_chsize in embed.h */
 #   undef my_chsize
@@ -3874,13 +3869,9 @@ PP(pp_fork)
     Pid_t childpid;
     GV *tmpgv;
 
-#   if defined(USE_ITHREADS) && !defined(HAS_PTHREAD_ATFORK)
-	Perl_croak(aTHX_ "No pthread_atfork() -- fork() too unsafe");
-#   endif
-
     EXTEND(SP, 1);
     PERL_FLUSHALL_FOR_CHILD;
-    childpid = fork();
+    childpid = PerlProc_fork();
     if (childpid < 0)
 	RETSETUNDEF;
     if (!childpid) {
@@ -3991,7 +3982,7 @@ PP(pp_system)
 	 
 	 if (PerlProc_pipe(pp) >= 0)
 	      did_pipes = 1;
-	 while ((childpid = vfork()) == -1) {
+	 while ((childpid = PerlProc_fork()) == -1) {
 	      if (errno != EAGAIN) {
 		   value = -1;
 		   SP = ORIGMARK;
@@ -4019,7 +4010,7 @@ PP(pp_system)
 	      (void)rsignal_restore(SIGQUIT, &qhand);
 #endif
 	      STATUS_NATIVE_SET(result == -1 ? -1 : status);
-	      do_execfree();	/* free any memory child malloced on vfork */
+	      do_execfree();	/* free any memory child malloced on fork */
 	      SP = ORIGMARK;
 	      if (did_pipes) {
 		   int errkid;
diff --git a/proto.h b/proto.h
index d03b3daa86..def3db1250 100644
--- a/proto.h
+++ b/proto.h
@@ -496,6 +496,9 @@ PERL_CALLCONV char*	Perl_my_bzero(char* loc, I32 len);
 PERL_CALLCONV void	Perl_my_exit(pTHX_ U32 status) __attribute__((noreturn));
 PERL_CALLCONV void	Perl_my_failure_exit(pTHX) __attribute__((noreturn));
 PERL_CALLCONV I32	Perl_my_fflush_all(pTHX);
+PERL_CALLCONV Pid_t	Perl_my_fork(void);
+PERL_CALLCONV void	Perl_atfork_lock(void);
+PERL_CALLCONV void	Perl_atfork_unlock(void);
 PERL_CALLCONV I32	Perl_my_lstat(pTHX);
 #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
 PERL_CALLCONV I32	Perl_my_memcmp(const char* s1, const char* s2, I32 len);
diff --git a/thread.h b/thread.h
index 3b26b17e50..fae53f1617 100644
--- a/thread.h
+++ b/thread.h
@@ -302,9 +302,6 @@
     } STMT_END
 #endif
 
-void Perl_atfork_lock(void);
-void Perl_atfork_unlock(void);
-
 #ifndef PTHREAD_ATFORK
 #  ifdef HAS_PTHREAD_ATFORK
 #    define PTHREAD_ATFORK(prepare,parent,child)		\
diff --git a/util.c b/util.c
index e01e836cd1..5262e6a2ed 100644
--- a/util.c
+++ b/util.c
@@ -26,17 +26,6 @@
 #endif
 #endif
 
-#ifdef I_VFORK
-#  include <vfork.h>
-#endif
-
-/* Put this after #includes because fork and vfork prototypes may
-   conflict.
-*/
-#ifndef HAS_VFORK
-#   define vfork fork
-#endif
-
 #ifdef I_SYS_WAIT
 #  include <sys/wait.h>
 #endif
@@ -1858,7 +1847,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
     /* Try for another pipe pair for error return */
     if (PerlProc_pipe(pp) >= 0)
 	did_pipes = 1;
-    while ((pid = vfork()) < 0) {
+    while ((pid = PerlProc_fork()) < 0) {
 	if (errno != EAGAIN) {
 	    PerlLIO_close(p[This]);
 	    if (did_pipes) {
@@ -1910,7 +1899,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
 #undef THAT
     }
     /* Parent */
-    do_execfree();	/* free any memory malloced by child on vfork */
+    do_execfree();	/* free any memory malloced by child on fork */
     /* Close child's end of pipe */
     PerlLIO_close(p[that]);
     if (did_pipes)
@@ -1991,7 +1980,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
 	return Nullfp;
     if (doexec && PerlProc_pipe(pp) >= 0)
 	did_pipes = 1;
-    while ((pid = (doexec?vfork():fork())) < 0) {
+    while ((pid = PerlProc_fork()) < 0) {
 	if (errno != EAGAIN) {
 	    PerlLIO_close(p[This]);
 	    if (did_pipes) {
@@ -2052,7 +2041,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
 #undef THIS
 #undef THAT
     }
-    do_execfree();	/* free any memory malloced by child on vfork */
+    do_execfree();	/* free any memory malloced by child on fork */
     PerlLIO_close(p[that]);
     if (did_pipes)
 	PerlLIO_close(pp[1]);
@@ -2127,6 +2116,53 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
 
 #endif /* !DOSISH */
 
+/* this is called in parent before the fork() */
+void
+Perl_atfork_lock(void)
+{
+#if defined(USE_THREADS) || defined(USE_ITHREADS)
+    /* locks must be held in locking order (if any) */
+#  ifdef MYMALLOC
+    MUTEX_LOCK(&PL_malloc_mutex);
+#  endif
+    OP_REFCNT_LOCK;
+#endif
+}
+
+/* this is called in both parent and child after the fork() */
+void
+Perl_atfork_unlock(void)
+{
+#if defined(USE_THREADS) || defined(USE_ITHREADS)
+    /* locks must be released in same order as in atfork_lock() */
+#  ifdef MYMALLOC
+    MUTEX_UNLOCK(&PL_malloc_mutex);
+#  endif
+    OP_REFCNT_UNLOCK;
+#endif
+}
+
+Pid_t
+Perl_my_fork(void)
+{
+#if defined(HAS_FORK)
+    Pid_t pid;
+#if (defined(USE_THREADS) || defined(USE_ITHREADS)) && !defined(HAS_PTHREAD_ATFORK)
+    atfork_lock();
+    pid = fork();
+    atfork_unlock();
+#else
+    /* atfork_lock() and atfork_unlock() are installed as pthread_atfork()
+     * handlers elsewhere in the code */
+    pid = fork();
+#endif
+    return pid;
+#else
+    /* this "canna happen" since nothing should be calling here if !HAS_FORK */
+    Perl_croak_nocontext("fork() not available");
+#endif /* HAS_FORK */
+}
+
 #ifdef DUMP_FDS
 void
 Perl_dump_fds(pTHX_ char *s)