diff options
| -rw-r--r-- | embed.h | 12 | ||||
| -rwxr-xr-x | embed.pl | 3 | ||||
| -rw-r--r-- | global.sym | 3 | ||||
| -rw-r--r-- | iperlsys.h | 2 | ||||
| -rw-r--r-- | miniperlmain.c | 11 | ||||
| -rw-r--r-- | objXSUB.h | 12 | ||||
| -rw-r--r-- | perl.c | 23 | ||||
| -rw-r--r-- | perlapi.c | 24 | ||||
| -rw-r--r-- | pp_sys.c | 15 | ||||
| -rw-r--r-- | proto.h | 3 | ||||
| -rw-r--r-- | thread.h | 3 | ||||
| -rw-r--r-- | util.c | 66 |
12 files changed, 122 insertions, 55 deletions
@@ -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) @@ -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); @@ -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 @@ -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) { \ @@ -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) @@ -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; @@ -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); @@ -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) \ @@ -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) |