Attachment "atfork.diff" to
ticket [923072ffff]
added by
davidw
2004-03-25 19:25:40.
Index: tests//thread.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/thread.test,v
retrieving revision 1.10
diff -u -r1.10 thread.test
--- tests//thread.test 2 May 2000 22:02:36 -0000 1.10
+++ tests//thread.test 25 Mar 2004 11:29:20 -0000
@@ -258,6 +260,29 @@
threadReap
lrange $msg 0 2
} {cannot join thread}
+
+test thread-6.0 {See if tcl and threads survive a fork()} {testthread unixOnly} {
+ set pid [testfork]
+ if {$pid == 0} {
+ exit 0
+ } else {
+ set retpid [testwaitpid $pid]
+ }
+ expr $pid == $retpid
+} {1}
+
+test thread-6.1 {See if tcl, threads, and an event survive a fork()} {testthread unixOnly} {
+ after 1000 [list set foo 1]
+ set pid [testfork]
+ if {$pid == 0} {
+ vwait foo
+ exit 0
+ } else {
+ testwaitpid $pid
+ }
+ vwait foo
+ set foo
+} {1}
# cleanup
::tcltest::cleanupTests
Index: unix//tcl.m4
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tcl.m4,v
retrieving revision 1.114
diff -u -r1.114 tcl.m4
--- unix//tcl.m4 18 Mar 2004 19:01:43 -0000 1.114
+++ unix//tcl.m4 25 Mar 2004 11:29:23 -0000
@@ -469,6 +469,7 @@
ac_saved_libs=$LIBS
LIBS="$LIBS $THREADS_LIBS"
AC_CHECK_FUNCS(pthread_attr_setstacksize)
+ AC_CHECK_FUNCS(pthread_atfork)
LIBS=$ac_saved_libs
AC_CHECK_FUNCS(readdir_r)
else
Index: unix//tclUnixInit.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclUnixInit.c,v
retrieving revision 1.39
diff -u -r1.39 tclUnixInit.c
--- unix//tclUnixInit.c 9 Mar 2004 13:34:45 -0000 1.39
+++ unix//tclUnixInit.c 25 Mar 2004 11:29:23 -0000
@@ -935,6 +935,15 @@
return result;
}
+#if defined(TCL_THREADS) && defined(HAVE_PTHREAD_ATFORK)
+static pthread_once_t once = PTHREAD_ONCE_INIT;
+
+static void
+InitAtfork(void)
+{
+ pthread_atfork(TclpAtforkLock, TclpAtForkParent, TclpAtForkChild);
+}
+#endif
/*
*----------------------------------------------------------------------
*
@@ -965,12 +974,17 @@
return (TCL_ERROR);
};
}
-
+
+#if defined(TCL_THREADS) && defined(HAVE_PTHREAD_ATFORK)
+ pthread_once(&once, InitAtfork);
+#endif
+
pathPtr = TclGetLibraryPath();
if (pathPtr == NULL) {
pathPtr = Tcl_NewObj();
}
Tcl_SetVar2Ex(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY);
+
return Tcl_Eval(interp, initScript);
}
Index: unix//tclUnixPort.h
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclUnixPort.h,v
retrieving revision 1.34
diff -u -r1.34 tclUnixPort.h
--- unix//tclUnixPort.h 9 Mar 2004 13:32:26 -0000 1.34
+++ unix//tclUnixPort.h 25 Mar 2004 11:29:24 -0000
@@ -578,6 +578,10 @@
*/
#define NO_REALPATH
#endif
+EXTERN void TclpAtforkLock(void);
+EXTERN void TclpAtforkUnlock(void);
+EXTERN void TclpAtForkChild(void);
+EXTERN void TclpAtForkParent(void);
#else
typedef int TclpMutex;
#define TclpMutexInit(a)
Index: unix//tclUnixTest.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclUnixTest.c,v
retrieving revision 1.15
diff -u -r1.15 tclUnixTest.c
--- unix//tclUnixTest.c 13 Oct 2003 00:59:48 -0000 1.15
+++ unix//tclUnixTest.c 25 Mar 2004 11:29:24 -0000
@@ -82,6 +82,10 @@
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestgotsigCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
+static int TestforkCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int argc, CONST char **argv));
+static int TestwaitpidCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
static void AlarmHandler _ANSI_ARGS_(());
/*
@@ -121,6 +125,10 @@
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testgotsig", TestgotsigCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateCommand(interp, "testfork", TestforkCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testwaitpid", TestwaitpidCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
return TCL_OK;
}
@@ -701,5 +709,82 @@
{
Tcl_AppendResult(interp, gotsig, (char *) NULL);
gotsig = "0";
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ * TestforkCmd --
+ *
+ * Implementation of fork().
+ *
+ * Results:
+ * In the parent process, the child process' pid, in the child, 0.
+ *
+ * Side Effects:
+ * Creates a new process.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestforkCmd(clientData, interp, argc, argv)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ CONST char **argv; /* Argument strings. */
+{
+ pid_t pid;
+
+ pid = fork();
+ if (pid < 0) {
+ Tcl_AppendResult(interp, "fork failed: ",
+ Tcl_PosixError(interp),
+ (char *)NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetIntObj (Tcl_GetObjResult (interp), (int)pid);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ * TestwaitpidCmd --
+ *
+ * Implementation of waitpid().
+ *
+ * Results:
+ * Returns the PID of the process we waited on.
+ *
+ * Side Effects:
+ * Waits untill the process in question exits.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestwaitpidCmd(clientData, interp, objc, objv)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument strings. */
+{
+ pid_t pid = 0;
+ pid_t returnPid = 0;
+ int status = 0;
+
+ if (Tcl_GetIntFromObj(interp, objv[1], &pid) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ returnPid = waitpid(pid, &status, 0);
+ if (returnPid < 0) {
+ Tcl_AppendResult(interp, "wait failed: ",
+ Tcl_PosixError(interp),
+ (char *)NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(returnPid));
+
return TCL_OK;
}
