diff options
author | jan.nijtmans <nijtmans@users.sourceforge.net> | 2013-07-21 14:52:57 (GMT) |
---|---|---|
committer | jan.nijtmans <nijtmans@users.sourceforge.net> | 2013-07-21 14:52:57 (GMT) |
commit | 4f645e7d24cb24959ae8aea7b54297b421d506f5 (patch) | |
tree | 3c6af0716f2bff72cada3681baaa8a464c06e259 /unix/tclUnixTest.c | |
parent | ae8d32e17d3ddc932def49dc45643928d7fe97ea (diff) | |
parent | 6b9dcf87ecc79d795e79e3d6d8e03b894f36a6cc (diff) | |
download | tcl-4f645e7d24cb24959ae8aea7b54297b421d506f5.zip tcl-4f645e7d24cb24959ae8aea7b54297b421d506f5.tar.gz tcl-4f645e7d24cb24959ae8aea7b54297b421d506f5.tar.bz2 |
Rebase to core-8-5-branch
Add "testfork" test command to be usable in testcase.
Diffstat (limited to 'unix/tclUnixTest.c')
-rw-r--r-- | unix/tclUnixTest.c | 47 |
1 files changed, 47 insertions, 0 deletions
diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index b6529c2..39cddef 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,49 @@ 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; + } + if (pid==0) { + Tcl_InitNotifier(); + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(pid)); + return TCL_OK; +} /* *---------------------------------------------------------------------- |