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

diff --git a/embed.h b/embed.h
index f6176db..9093f9b 100644 (file)
--- 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 f125ef0..2e473b6 100755 (executable)
--- 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 5301739..73493c3 100644 (file)
--- 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 081d8b2..89b551b 100644 (file)
--- 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 620fed7..2c924eb 100644 (file)
--- 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 43a10fa..564bd9c 100644 (file)
--- 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 25cdcd6..322960d 100644 (file)
--- 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 fb5c407..9b90154 100644 (file)
--- 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 6a74b11..ac7ca20 100644 (file)
--- 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 d03b3da..def3db1 100644 (file)
--- 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 3b26b17..fae53f1 100644 (file)
--- 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 e01e836..5262e6a 100644 (file)
--- 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)