summaryrefslogtreecommitdiffstats
path: root/unix/tclUnixTest.c
diff options
context:
space:
mode:
Diffstat (limited to 'unix/tclUnixTest.c')
-rw-r--r--unix/tclUnixTest.c50
1 files changed, 50 insertions, 0 deletions
diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c
index b6529c2..2fc1647 100644
--- a/unix/tclUnixTest.c
+++ b/unix/tclUnixTest.c
@@ -66,6 +66,8 @@ static int TestfilewaitCmd(ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv);
static int TestfindexecutableCmd(ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv);
+static int TestforkObjCmd(ClientData dummy,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST *argv);
static int TestgetopenfileCmd(ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv);
static int TestgetdefencdirCmd(ClientData dummy,
@@ -110,6 +112,8 @@ TclplatformtestInit(
(ClientData) 0, NULL);
Tcl_CreateCommand(interp, "testfindexecutable", TestfindexecutableCmd,
(ClientData) 0, NULL);
+ Tcl_CreateObjCommand(interp, "testfork", TestforkObjCmd,
+ (ClientData) 0, NULL);
Tcl_CreateCommand(interp, "testgetopenfile", TestgetopenfileCmd,
(ClientData) 0, NULL);
Tcl_CreateCommand(interp, "testgetdefenc", TestgetdefencdirCmd,
@@ -533,6 +537,52 @@ TestsetdefencdirCmd(
Tcl_SetDefaultEncodingDir(argv[1]);
return TCL_OK;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestforkObjCmd --
+ *
+ * This function implements the "testfork" command. It is used to
+ * fork the Tcl process for specific test cases.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestforkObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST *objv) /* Argument strings. */
+{
+ pid_t pid;
+
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, "");
+ return TCL_ERROR;
+ }
+ pid = fork();
+ if (pid == -1) {
+ Tcl_AppendResult(interp,
+ "Cannot fork", NULL);
+ return TCL_ERROR;
+ }
+#ifndef HAVE_PTHREAD_ATFORK
+ /* Only needed when pthread_atfork is not present. */
+ if (pid==0) {
+ Tcl_InitNotifier();
+ }
+#endif
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(pid));
+ return TCL_OK;
+}
/*
*----------------------------------------------------------------------