diff options
author | kjnash <k.j.nash@usa.net> | 2020-08-11 18:23:18 (GMT) |
---|---|---|
committer | kjnash <k.j.nash@usa.net> | 2020-08-11 18:23:18 (GMT) |
commit | 17058912aa60f6a98953579de27b7876ce1ec4dd (patch) | |
tree | 51d0b47799e0221f5a9ec3e65eb4145c68288cf2 /generic/tclTest.c | |
parent | c890584ff70ab28383f53c477a63e4d9189dd113 (diff) | |
parent | b3f8c269fa4910edabe381bf6ec17ecdb2bb19e1 (diff) | |
download | tcl-17058912aa60f6a98953579de27b7876ce1ec4dd.zip tcl-17058912aa60f6a98953579de27b7876ce1ec4dd.tar.gz tcl-17058912aa60f6a98953579de27b7876ce1ec4dd.tar.bz2 |
Merge 8.7
Diffstat (limited to 'generic/tclTest.c')
-rw-r--r-- | generic/tclTest.c | 52 |
1 files changed, 51 insertions, 1 deletions
diff --git a/generic/tclTest.c b/generic/tclTest.c index 8cca744..7b0df05 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -312,7 +312,7 @@ static Tcl_FSNormalizePathProc TestReportNormalizePath; static Tcl_FSPathInFilesystemProc TestReportInFilesystem; static Tcl_FSFreeInternalRepProc TestReportFreeInternalRep; static Tcl_FSDupInternalRepProc TestReportDupInternalRep; - +static Tcl_CmdProc TestServiceModeCmd; static Tcl_FSStatProc SimpleStat; static Tcl_FSAccessProc SimpleAccess; static Tcl_FSOpenFileChannelProc SimpleOpenFileChannel; @@ -573,6 +573,8 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, NULL, NULL); + Tcl_CreateCommand(interp, "testservicemode", TestServiceModeCmd, + NULL, NULL); Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd, @@ -6164,6 +6166,54 @@ TestSocketCmd( /* *---------------------------------------------------------------------- * + * TestServiceModeCmd -- + * + * This procedure implements the "testservicemode" command which gets or + * sets the current Tcl ServiceMode. There are several tests which open + * a file and assign various handlers to it. For these tests to be + * deterministic it is important that file events not be processed until + * all of the handlers are in place. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May change the ServiceMode setting. + * + *---------------------------------------------------------------------- + */ + +static int +TestServiceModeCmd( + TCL_UNUSED(ClientData), + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ +{ + int newmode, oldmode; + if (argc > 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?newmode?\"", NULL); + return TCL_ERROR; + } + oldmode = (Tcl_GetServiceMode() != TCL_SERVICE_NONE); + if (argc == 2) { + if (Tcl_GetInt(interp, argv[1], &newmode) == TCL_ERROR) { + return TCL_ERROR; + } + if (newmode == 0) { + Tcl_SetServiceMode(TCL_SERVICE_NONE); + } else { + Tcl_SetServiceMode(TCL_SERVICE_ALL); + } + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(oldmode)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestWrongNumArgsObjCmd -- * * Test the Tcl_WrongNumArgs function. |