summaryrefslogtreecommitdiffstats
path: root/generic/tclTest.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclTest.c')
-rw-r--r--generic/tclTest.c419
1 files changed, 335 insertions, 84 deletions
diff --git a/generic/tclTest.c b/generic/tclTest.c
index eb6b589..736d723 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -55,6 +55,21 @@ static Tcl_DString delString;
static Tcl_Interp *delInterp;
/*
+ * One of the following structures exists for each command created by the
+ * "testcmdtoken" command.
+ */
+
+typedef struct TestCommandTokenRef {
+ int id; /* Identifier for this reference. */
+ Tcl_Command token; /* Tcl's token for the command. */
+ struct TestCommandTokenRef *nextPtr;
+ /* Next in list of references. */
+} TestCommandTokenRef;
+
+static TestCommandTokenRef *firstCommandTokenRef = NULL;
+static int nextCommandTokenRefId = 1;
+
+/*
* One of the following structures exists for each asynchronous handler
* created by the "testasync" command".
*/
@@ -76,8 +91,7 @@ typedef struct TcpState TcpState;
struct TcpState {
Tcl_Channel channel; /* Channel associated with this socket. */
- int testFlags; /* bit field for tests. Is set by testsocket
- * test procedure */
+ int flags; /* ORed combination of various bitfields. */
};
TCL_DECLARE_MUTEX(asyncTestMutex)
@@ -156,6 +170,15 @@ typedef struct TestChannel {
static TestChannel *firstDetached;
+#ifdef __GNUC__
+/*
+ * The rest of this file shouldn't warn about deprecated functions; they're
+ * there because we intend them to be so and know that this file is OK to
+ * touch those fields.
+ */
+#pragma GCC diagnostic ignored "-Wdeprecated-declarations"
+#endif
+
/*
* Forward declarations for procedures defined later in this file:
*/
@@ -251,6 +274,7 @@ static Tcl_ObjCmdProc TestgetvarfullnameCmd;
static Tcl_CmdProc TestinterpdeleteCmd;
static Tcl_CmdProc TestlinkCmd;
static Tcl_ObjCmdProc TestlinkarrayCmd;
+static Tcl_ObjCmdProc TestlistrepCmd;
static Tcl_ObjCmdProc TestlocaleCmd;
static Tcl_CmdProc TestmainthreadCmd;
static Tcl_CmdProc TestsetmainloopCmd;
@@ -277,7 +301,7 @@ static Tcl_CmdProc TestsetplatformCmd;
static Tcl_CmdProc TeststaticlibraryCmd;
static Tcl_CmdProc TesttranslatefilenameCmd;
static Tcl_CmdProc TestupvarCmd;
-static Tcl_ObjCmdProc TestWrongNumArgsObjCmd;
+static Tcl_ObjCmdProc2 TestWrongNumArgsObjCmd;
static Tcl_ObjCmdProc TestGetIndexFromObjStructObjCmd;
static Tcl_CmdProc TestChannelCmd;
static Tcl_CmdProc TestChannelEventCmd;
@@ -539,6 +563,12 @@ Tcltest_Init(
}
if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) {
+#if TCL_MAJOR_VERSION > 8
+ if (info.isNativeObjectProc == 2) {
+ Tcl_CreateObjCommand2(interp, "::tcl::test::build-info",
+ info.objProc2, (void *)version, NULL);
+ } else
+#endif
Tcl_CreateObjCommand(interp, "::tcl::test::build-info",
info.objProc, (void *)version, NULL);
}
@@ -557,7 +587,7 @@ Tcltest_Init(
Tcl_CreateObjCommand(interp, "testsetbytearraylength", TestsetbytearraylengthObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL);
- Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
+ Tcl_CreateObjCommand2(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
NULL, NULL);
@@ -635,6 +665,7 @@ Tcltest_Init(
NULL, NULL);
Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testlinkarray", TestlinkarrayCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testlistrep", TestlistrepCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL);
@@ -749,7 +780,7 @@ Tcltest_Init(
return TCL_ERROR;
}
case 3:
- if (objc-1) {
+ if (objc > 1) {
Tcl_SetVar2Ex(interp, "tcl_rcFileName", NULL, objv[1],
TCL_GLOBAL_ONLY);
}
@@ -794,6 +825,12 @@ Tcltest_SafeInit(
return TCL_ERROR;
}
if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) {
+#if TCL_MAJOR_VERSION > 8
+ if (info.isNativeObjectProc == 2) {
+ Tcl_CreateObjCommand2(interp, "::tcl::test::build-info",
+ info.objProc2, (void *)version, NULL);
+ } else
+#endif
Tcl_CreateObjCommand(interp, "::tcl::test::build-info",
info.objProc, (void *)version, NULL);
}
@@ -904,7 +941,7 @@ TestasyncCmd(
break;
}
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], TCL_INDEX_NONE));
Tcl_MutexUnlock(&asyncTestMutex);
return code;
} else if (strcmp(argv[1], "marklater") == 0) {
@@ -973,7 +1010,7 @@ AsyncHandlerProc(
listArgv[3] = NULL;
cmd = Tcl_Merge(3, listArgv);
if (interp != NULL) {
- code = Tcl_EvalEx(interp, cmd, -1, 0);
+ code = Tcl_EvalEx(interp, cmd, TCL_INDEX_NONE, 0);
} else {
/*
* this should not happen, but by definition of how async handlers are
@@ -1154,8 +1191,8 @@ CmdDelProc1(
void *clientData) /* String to save. */
{
Tcl_DStringInit(&delString);
- Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1);
- Tcl_DStringAppend(&delString, (char *) clientData, -1);
+ Tcl_DStringAppend(&delString, "CmdDelProc1 ", TCL_INDEX_NONE);
+ Tcl_DStringAppend(&delString, (char *) clientData, TCL_INDEX_NONE);
}
static void
@@ -1163,8 +1200,8 @@ CmdDelProc2(
void *clientData) /* String to save. */
{
Tcl_DStringInit(&delString);
- Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1);
- Tcl_DStringAppend(&delString, (char *) clientData, -1);
+ Tcl_DStringAppend(&delString, "CmdDelProc2 ", TCL_INDEX_NONE);
+ Tcl_DStringAppend(&delString, (char *) clientData, TCL_INDEX_NONE);
}
/*
@@ -1191,9 +1228,9 @@ TestcmdtokenCmd(
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
- Tcl_Command token;
- int *l;
+ TestCommandTokenRef *refPtr;
char buf[30];
+ int id;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
@@ -1201,24 +1238,42 @@ TestcmdtokenCmd(
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
- token = Tcl_CreateCommand(interp, argv[2], CmdProc1,
+ refPtr = (TestCommandTokenRef *)Tcl_Alloc(sizeof(TestCommandTokenRef));
+ refPtr->token = Tcl_CreateCommand(interp, argv[2], CmdProc1,
(void *) "original", NULL);
- sprintf(buf, "%p", (void *)token);
+ refPtr->id = nextCommandTokenRefId;
+ nextCommandTokenRefId++;
+ refPtr->nextPtr = firstCommandTokenRef;
+ firstCommandTokenRef = refPtr;
+ sprintf(buf, "%d", refPtr->id);
Tcl_AppendResult(interp, buf, NULL);
} else if (strcmp(argv[1], "name") == 0) {
Tcl_Obj *objPtr;
- if (sscanf(argv[2], "%p", &l) != 1) {
+ if (sscanf(argv[2], "%d", &id) != 1) {
+ Tcl_AppendResult(interp, "bad command token \"", argv[2],
+ "\"", NULL);
+ return TCL_ERROR;
+ }
+
+ for (refPtr = firstCommandTokenRef; refPtr != NULL;
+ refPtr = refPtr->nextPtr) {
+ if (refPtr->id == id) {
+ break;
+ }
+ }
+
+ if (refPtr == NULL) {
Tcl_AppendResult(interp, "bad command token \"", argv[2],
"\"", NULL);
return TCL_ERROR;
}
objPtr = Tcl_NewObj();
- Tcl_GetCommandFullName(interp, (Tcl_Command) l, objPtr);
+ Tcl_GetCommandFullName(interp, refPtr->token, objPtr);
Tcl_AppendElement(interp,
- Tcl_GetCommandName(interp, (Tcl_Command) l));
+ Tcl_GetCommandName(interp, refPtr->token));
Tcl_AppendElement(interp, Tcl_GetString(objPtr));
Tcl_DecrRefCount(objPtr);
} else {
@@ -1266,7 +1321,7 @@ TestcmdtraceCmd(
if (strcmp(argv[1], "tracetest") == 0) {
Tcl_DStringInit(&buffer);
cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer);
- result = Tcl_EvalEx(interp, argv[2], -1, 0);
+ result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
@@ -1282,13 +1337,13 @@ TestcmdtraceCmd(
*/
cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceDeleteProc, NULL);
- Tcl_EvalEx(interp, argv[2], -1, 0);
+ Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0);
} else if (strcmp(argv[1], "leveltest") == 0) {
Interp *iPtr = (Interp *) interp;
Tcl_DStringInit(&buffer);
cmdTrace = Tcl_CreateTrace(interp, iPtr->numLevels + 4, CmdTraceProc,
&buffer);
- result = Tcl_EvalEx(interp, argv[2], -1, 0);
+ result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
@@ -1306,7 +1361,7 @@ TestcmdtraceCmd(
cmdTrace = Tcl_CreateObjTrace(interp, 50000,
TCL_ALLOW_INLINE_COMPILATION, ObjTraceProc,
&deleteCalled, ObjTraceDeleteProc);
- result = Tcl_EvalEx(interp, argv[2], -1, 0);
+ result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0);
Tcl_DeleteTrace(interp, cmdTrace);
if (!deleteCalled) {
Tcl_AppendResult(interp, "Delete wasn't called", NULL);
@@ -1320,7 +1375,7 @@ TestcmdtraceCmd(
Tcl_DStringInit(&buffer);
t1 = Tcl_CreateTrace(interp, 1, CmdTraceProc, &buffer);
t2 = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer);
- result = Tcl_EvalEx(interp, argv[2], -1, 0);
+ result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
@@ -1395,7 +1450,7 @@ ObjTraceProc(
const char *word = Tcl_GetString(objv[0]);
if (!strcmp(word, "Error")) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(command, -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(command, TCL_INDEX_NONE));
return TCL_ERROR;
} else if (!strcmp(word, "Break")) {
return TCL_BREAK;
@@ -1644,7 +1699,7 @@ DelDeleteProc(
{
DelCmd *dPtr = (DelCmd *)clientData;
- Tcl_EvalEx(dPtr->interp, dPtr->deleteCmd, -1, 0);
+ Tcl_EvalEx(dPtr->interp, dPtr->deleteCmd, TCL_INDEX_NONE, 0);
Tcl_ResetResult(dPtr->interp);
Tcl_Free(dPtr->deleteCmd);
Tcl_Free(dPtr);
@@ -1759,7 +1814,7 @@ TestdoubledigitsObjCmd(
type = types[type];
if (objc > 4) {
if (strcmp(Tcl_GetString(objv[4]), "shorten")) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj("bad flag", -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("bad flag", TCL_INDEX_NONE));
return TCL_ERROR;
}
type |= TCL_DD_SHORTEST;
@@ -2003,7 +2058,7 @@ EncodingToUtfProc(
TclEncoding *encodingPtr;
encodingPtr = (TclEncoding *) clientData;
- Tcl_EvalEx(encodingPtr->interp, encodingPtr->toUtfCmd, -1, TCL_EVAL_GLOBAL);
+ Tcl_EvalEx(encodingPtr->interp, encodingPtr->toUtfCmd, TCL_INDEX_NONE, TCL_EVAL_GLOBAL);
len = strlen(Tcl_GetStringResult(encodingPtr->interp));
if (len > dstLen) {
@@ -2035,7 +2090,7 @@ EncodingFromUtfProc(
TclEncoding *encodingPtr;
encodingPtr = (TclEncoding *) clientData;
- Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd, -1, TCL_EVAL_GLOBAL);
+ Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd, TCL_INDEX_NONE, TCL_EVAL_GLOBAL);
len = strlen(Tcl_GetStringResult(encodingPtr->interp));
if (len > dstLen) {
@@ -3074,7 +3129,7 @@ TestlinkCmd(
}
}
if (argv[6][0] != 0) {
- tmp = Tcl_NewStringObj(argv[6], -1);
+ tmp = Tcl_NewStringObj(argv[6], TCL_INDEX_NONE);
if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
Tcl_DecrRefCount(tmp);
return TCL_ERROR;
@@ -3132,7 +3187,7 @@ TestlinkCmd(
}
if (argv[15][0]) {
Tcl_WideInt w;
- tmp = Tcl_NewStringObj(argv[15], -1);
+ tmp = Tcl_NewStringObj(argv[15], TCL_INDEX_NONE);
if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) {
Tcl_DecrRefCount(tmp);
return TCL_ERROR;
@@ -3182,7 +3237,7 @@ TestlinkCmd(
Tcl_UpdateLinkedVar(interp, "string");
}
if (argv[6][0] != 0) {
- tmp = Tcl_NewStringObj(argv[6], -1);
+ tmp = Tcl_NewStringObj(argv[6], TCL_INDEX_NONE);
if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
Tcl_DecrRefCount(tmp);
return TCL_ERROR;
@@ -3249,7 +3304,7 @@ TestlinkCmd(
}
if (argv[15][0]) {
Tcl_WideInt w;
- tmp = Tcl_NewStringObj(argv[15], -1);
+ tmp = Tcl_NewStringObj(argv[15], TCL_INDEX_NONE);
if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) {
Tcl_DecrRefCount(tmp);
return TCL_ERROR;
@@ -3356,7 +3411,7 @@ TestlinkarrayCmd(
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[i++], &size) == TCL_ERROR) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong size value", -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong size value", TCL_INDEX_NONE));
return TCL_ERROR;
}
name = Tcl_GetString(objv[i++]);
@@ -3368,7 +3423,7 @@ TestlinkarrayCmd(
if (i < objc) {
if (Tcl_GetWideIntFromObj(interp, objv[i], &addr) == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "wrong address value", -1));
+ "wrong address value", TCL_INDEX_NONE));
return TCL_ERROR;
}
} else {
@@ -3387,6 +3442,158 @@ TestlinkarrayCmd(
/*
*----------------------------------------------------------------------
*
+ * TestlistrepCmd --
+ *
+ * This function is invoked to generate a list object with a specific
+ * internal representation.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestlistrepCmd(
+ TCL_UNUSED(void *),
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ /* Subcommands supported by this command */
+ const char* subcommands[] = {
+ "new",
+ "describe",
+ "config",
+ "validate",
+ NULL
+ };
+ enum {
+ LISTREP_NEW,
+ LISTREP_DESCRIBE,
+ LISTREP_CONFIG,
+ LISTREP_VALIDATE
+ } cmdIndex;
+ Tcl_Obj *resultObj = NULL;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(
+ interp, objv[1], subcommands, "command", 0, &cmdIndex)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (cmdIndex) {
+ case LISTREP_NEW:
+ if (objc < 3 || objc > 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "length ?leadSpace endSpace?");
+ return TCL_ERROR;
+ } else {
+ int length;
+ int leadSpace = 0;
+ int endSpace = 0;
+ if (Tcl_GetIntFromObj(interp, objv[2], &length) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objc > 3) {
+ if (Tcl_GetIntFromObj(interp, objv[3], &leadSpace) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objc > 4) {
+ if (Tcl_GetIntFromObj(interp, objv[4], &endSpace)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+ }
+ resultObj = TclListTestObj(length, leadSpace, endSpace);
+ }
+ break;
+
+ case LISTREP_DESCRIBE:
+#define APPEND_FIELD(targetObj_, structPtr_, fld_) \
+ do { \
+ Tcl_ListObjAppendElement( \
+ interp, (targetObj_), Tcl_NewStringObj(#fld_, TCL_INDEX_NONE)); \
+ Tcl_ListObjAppendElement( \
+ interp, (targetObj_), Tcl_NewWideIntObj((structPtr_)->fld_)); \
+ } while (0)
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "object");
+ return TCL_ERROR;
+ } else {
+ Tcl_Obj **objs;
+ ListSizeT nobjs;
+ ListRep listRep;
+ Tcl_Obj *listRepObjs[4];
+
+ /* Force list representation */
+ if (Tcl_ListObjGetElements(interp, objv[2], &nobjs, &objs) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ ListObjGetRep(objv[2], &listRep);
+ listRepObjs[0] = Tcl_NewStringObj("store", TCL_INDEX_NONE);
+ listRepObjs[1] = Tcl_NewListObj(12, NULL);
+ Tcl_ListObjAppendElement(
+ interp, listRepObjs[1], Tcl_NewStringObj("memoryAddress", TCL_INDEX_NONE));
+ Tcl_ListObjAppendElement(
+ interp, listRepObjs[1], Tcl_ObjPrintf("%p", listRep.storePtr));
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, firstUsed);
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, numUsed);
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, numAllocated);
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, refCount);
+ APPEND_FIELD(listRepObjs[1], listRep.storePtr, flags);
+ if (listRep.spanPtr) {
+ listRepObjs[2] = Tcl_NewStringObj("span", TCL_INDEX_NONE);
+ listRepObjs[3] = Tcl_NewListObj(8, NULL);
+ Tcl_ListObjAppendElement(interp,
+ listRepObjs[3],
+ Tcl_NewStringObj("memoryAddress", TCL_INDEX_NONE));
+ Tcl_ListObjAppendElement(
+ interp, listRepObjs[3], Tcl_ObjPrintf("%p", listRep.spanPtr));
+ APPEND_FIELD(listRepObjs[3], listRep.spanPtr, spanStart);
+ APPEND_FIELD(
+ listRepObjs[3], listRep.spanPtr, spanLength);
+ APPEND_FIELD(listRepObjs[3], listRep.spanPtr, refCount);
+ }
+ resultObj = Tcl_NewListObj(listRep.spanPtr ? 4 : 2, listRepObjs);
+ }
+#undef APPEND_FIELD
+ break;
+
+ case LISTREP_CONFIG:
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, "object");
+ return TCL_ERROR;
+ }
+ resultObj = Tcl_NewListObj(2, NULL);
+ Tcl_ListObjAppendElement(
+ NULL, resultObj, Tcl_NewStringObj("LIST_SPAN_THRESHOLD", TCL_INDEX_NONE));
+ Tcl_ListObjAppendElement(
+ NULL, resultObj, Tcl_NewWideIntObj(LIST_SPAN_THRESHOLD));
+ break;
+
+ case LISTREP_VALIDATE:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "object");
+ return TCL_ERROR;
+ }
+ TclListObjValidate(interp, objv[2]); /* Panics if invalid */
+ resultObj = Tcl_NewObj();
+ break;
+ }
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestlocaleCmd --
*
* This procedure implements the "testlocale" command. It is used
@@ -3440,7 +3647,7 @@ TestlocaleCmd(
}
locale = setlocale(lcTypes[index], locale);
if (locale) {
- Tcl_SetStringObj(Tcl_GetObjResult(interp), locale, -1);
+ Tcl_SetStringObj(Tcl_GetObjResult(interp), locale, TCL_INDEX_NONE);
}
return TCL_OK;
}
@@ -3662,7 +3869,7 @@ PrintParse(
break;
}
Tcl_ListObjAppendElement(NULL, objPtr,
- Tcl_NewStringObj(typeString, -1));
+ Tcl_NewStringObj(typeString, TCL_INDEX_NONE));
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj(tokenPtr->start, tokenPtr->size));
Tcl_ListObjAppendElement(NULL, objPtr,
@@ -3671,7 +3878,7 @@ PrintParse(
Tcl_ListObjAppendElement(NULL, objPtr,
parsePtr->commandStart ?
Tcl_NewStringObj(parsePtr->commandStart + parsePtr->commandSize,
- -1) : Tcl_NewObj());
+ TCL_INDEX_NONE) : Tcl_NewObj());
}
/*
@@ -3990,7 +4197,7 @@ TestregexpObjCmd(
char resinfo[TCL_INTEGER_SPACE * 2];
varName = Tcl_GetString(objv[2]);
- TclRegExpRangeUniChar(regExpr, -1, &start, &end);
+ TclRegExpRangeUniChar(regExpr, TCL_INDEX_NONE, &start, &end);
sprintf(resinfo, "%" TCL_Z_MODIFIER "d %" TCL_Z_MODIFIER "d", start, (end-1));
value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0);
if (value == NULL) {
@@ -4565,7 +4772,7 @@ TestfeventCmd(
return TCL_ERROR;
}
if (interp2 != NULL) {
- code = Tcl_EvalEx(interp2, argv[2], -1, TCL_EVAL_GLOBAL);
+ code = Tcl_EvalEx(interp2, argv[2], TCL_INDEX_NONE, TCL_EVAL_GLOBAL);
Tcl_SetObjResult(interp, Tcl_GetObjResult(interp2));
return code;
} else {
@@ -4860,7 +5067,7 @@ GetTimesObjCmd(
/* TclGetString 100000 times */
fprintf(stderr, "Tcl_GetStringFromObj of \"12345\" 100000 times\n");
- objPtr = Tcl_NewStringObj("12345", -1);
+ objPtr = Tcl_NewStringObj("12345", TCL_INDEX_NONE);
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
(void) TclGetString(objPtr);
@@ -5331,7 +5538,7 @@ TestsaveresultCmd(
Tcl_SetResult(interp, (char *)"dynamic result", TestsaveresultFree);
break;
case RESULT_OBJECT:
- objPtr = Tcl_NewStringObj("object result", -1);
+ objPtr = Tcl_NewStringObj("object result", TCL_INDEX_NONE);
Tcl_SetObjResult(interp, objPtr);
break;
}
@@ -5341,7 +5548,7 @@ TestsaveresultCmd(
if (index == RESULT_OBJECT) {
result = Tcl_EvalObjEx(interp, objv[2], 0);
} else {
- result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), -1, 0);
+ result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), TCL_INDEX_NONE, 0);
}
if (discard) {
@@ -5590,7 +5797,7 @@ TestChannelCmd(
if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerror", len) == 0)) {
- Tcl_Obj *msg = Tcl_NewStringObj(argv[3],-1);
+ Tcl_Obj *msg = Tcl_NewStringObj(argv[3], TCL_INDEX_NONE);
Tcl_IncrRefCount(msg);
Tcl_SetChannelError(chan, msg);
@@ -5603,7 +5810,7 @@ TestChannelCmd(
}
if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerrorinterp", len) == 0)) {
- Tcl_Obj *msg = Tcl_NewStringObj(argv[3],-1);
+ Tcl_Obj *msg = Tcl_NewStringObj(argv[3], TCL_INDEX_NONE);
Tcl_IncrRefCount(msg);
Tcl_SetChannelErrorInterp(interp, msg);
@@ -5802,6 +6009,45 @@ TestChannelCmd(
return TCL_OK;
}
+ if ((cmdName[0] == 'm') && (strncmp(cmdName, "maxmode", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required", NULL);
+ return TCL_ERROR;
+ }
+
+ if (statePtr->maxPerms & TCL_READABLE) {
+ Tcl_AppendElement(interp, "read");
+ } else {
+ Tcl_AppendElement(interp, "");
+ }
+ if (statePtr->maxPerms & TCL_WRITABLE) {
+ Tcl_AppendElement(interp, "write");
+ } else {
+ Tcl_AppendElement(interp, "");
+ }
+ return TCL_OK;
+ }
+
+ if ((cmdName[0] == 'm') && (strncmp(cmdName, "mremove-rd", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ return Tcl_RemoveChannelMode(interp, chan, TCL_READABLE);
+ }
+
+ if ((cmdName[0] == 'm') && (strncmp(cmdName, "mremove-wr", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ return Tcl_RemoveChannelMode(interp, chan, TCL_WRITABLE);
+ }
+
if ((cmdName[0] == 'm') && (strncmp(cmdName, "mthread", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required", NULL);
@@ -5951,7 +6197,7 @@ TestChannelCmd(
}
return TclChannelTransform(interp, chan,
- Tcl_NewStringObj(argv[4], -1));
+ Tcl_NewStringObj(argv[4], TCL_INDEX_NONE));
}
if ((cmdName[0] == 'u') && (strncmp(cmdName, "unstack", len) == 0)) {
@@ -6042,7 +6288,7 @@ TestChannelEventCmd(
esPtr->chanPtr = chanPtr;
esPtr->interp = interp;
esPtr->mask = mask;
- esPtr->scriptPtr = Tcl_NewStringObj(argv[4], -1);
+ esPtr->scriptPtr = Tcl_NewStringObj(argv[4], TCL_INDEX_NONE);
Tcl_IncrRefCount(esPtr->scriptPtr);
Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
@@ -6109,10 +6355,10 @@ TestChannelEventCmd(
esPtr = esPtr->nextPtr) {
if (esPtr->mask) {
Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
- (esPtr->mask == TCL_READABLE) ? "readable" : "writable", -1));
+ (esPtr->mask == TCL_READABLE) ? "readable" : "writable", TCL_INDEX_NONE));
} else {
Tcl_ListObjAppendElement(interp, resultListPtr,
- Tcl_NewStringObj("none", -1));
+ Tcl_NewStringObj("none", TCL_INDEX_NONE));
}
Tcl_ListObjAppendElement(interp, resultListPtr, esPtr->scriptPtr);
}
@@ -6202,6 +6448,10 @@ TestChannelEventCmd(
*----------------------------------------------------------------------
*/
+#define TCP_ASYNC_TEST_MODE (1<<8) /* Async testing activated. Do not
+ * automatically continue connection
+ * process. */
+
static int
TestSocketCmd(
TCL_UNUSED(void *),
@@ -6223,6 +6473,7 @@ TestSocketCmd(
if ((cmdName[0] == 't') && (strncmp(cmdName, "testflags", len) == 0)) {
Tcl_Channel hChannel;
int modePtr;
+ int testMode;
TcpState *statePtr;
/* Set test value in the socket driver
*/
@@ -6244,7 +6495,14 @@ TestSocketCmd(
NULL);
return TCL_ERROR;
}
- statePtr->testFlags = atoi(argv[3]);
+ if (Tcl_GetBoolean(interp, argv[3], &testMode) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (testMode) {
+ statePtr->flags |= TCP_ASYNC_TEST_MODE;
+ } else {
+ statePtr->flags &= ~TCP_ASYNC_TEST_MODE;
+ }
return TCL_OK;
}
@@ -6321,22 +6579,17 @@ static int
TestWrongNumArgsObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
+ size_t objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int i, length;
+ size_t i, length;
const char *msg;
- if (objc < 3) {
- /*
- * Don't use Tcl_WrongNumArgs here, as that is the function
- * we want to test!
- */
- Tcl_AppendResult(interp, "insufficient arguments", NULL);
- return TCL_ERROR;
+ if (objc + 1 < 4) {
+ goto insufArgs;
}
- if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK) {
+ if (Tcl_GetIntForIndex(interp, objv[1], TCL_INDEX_NONE, &i) != TCL_OK) {
return TCL_ERROR;
}
@@ -6349,6 +6602,7 @@ TestWrongNumArgsObjCmd(
/*
* Asked for more arguments than were given.
*/
+ insufArgs:
Tcl_AppendResult(interp, "insufficient arguments", NULL);
return TCL_ERROR;
}
@@ -6459,7 +6713,7 @@ TestFilesystemObjCmd(
res = Tcl_FSUnregister(&testReportingFilesystem);
msg = (res == TCL_OK) ? "unregistered" : "failed";
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , TCL_INDEX_NONE));
return res;
}
@@ -6541,7 +6795,7 @@ TestReport(
Tcl_DString ds;
Tcl_DStringInit(&ds);
- Tcl_DStringAppend(&ds, "lappend filesystemReport ", -1);
+ Tcl_DStringAppend(&ds, "lappend filesystemReport ", TCL_INDEX_NONE);
Tcl_DStringStartSublist(&ds);
Tcl_DStringAppendElement(&ds, cmd);
if (path != NULL) {
@@ -6554,7 +6808,7 @@ TestReport(
savedResult = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(savedResult);
Tcl_SetObjResult(interp, Tcl_NewObj());
- Tcl_EvalEx(interp, Tcl_DStringValue(&ds), -1, 0);
+ Tcl_EvalEx(interp, Tcl_DStringValue(&ds), TCL_INDEX_NONE, 0);
Tcl_DStringFree(&ds);
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, savedResult);
@@ -6830,7 +7084,7 @@ TestSimpleFilesystemObjCmd(
res = Tcl_FSUnregister(&simpleFilesystem);
msg = (res == TCL_OK) ? "unregistered" : "failed";
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(msg , TCL_INDEX_NONE));
return res;
}
@@ -6857,7 +7111,7 @@ SimpleRedirect(
Tcl_IncrRefCount(pathPtr);
return pathPtr;
}
- origPtr = Tcl_NewStringObj(str+10,-1);
+ origPtr = Tcl_NewStringObj(str+10, TCL_INDEX_NONE);
Tcl_IncrRefCount(origPtr);
return origPtr;
}
@@ -6957,7 +7211,7 @@ SimpleListVolumes(void)
/* Add one new volume */
Tcl_Obj *retVal;
- retVal = Tcl_NewStringObj("simplefs:/", -1);
+ retVal = Tcl_NewStringObj("simplefs:/", TCL_INDEX_NONE);
Tcl_IncrRefCount(retVal);
return retVal;
}
@@ -6986,8 +7240,7 @@ TestUtfNextCmd(
Tcl_WrongNumArgs(interp, 1, objv, "?-bytestring? bytes");
return TCL_ERROR;
}
- bytes = Tcl_GetString(objv[1]);
- numBytes = objv[1]->length;
+ bytes = Tcl_GetStringFromObj(objv[1], &numBytes);
if (numBytes + 4U > sizeof(buffer)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -7046,8 +7299,7 @@ TestUtfPrevCmd(
return TCL_ERROR;
}
- bytes = Tcl_GetString(objv[1]);
- numBytes = objv[1]->length;
+ bytes = Tcl_GetStringFromObj(objv[1], &numBytes);
if (objc == 3) {
if (TCL_OK != Tcl_GetIntForIndex(interp, objv[2], numBytes, &offset)) {
@@ -7079,9 +7331,8 @@ TestNumUtfCharsCmd(
Tcl_Obj *const objv[])
{
if (objc > 1) {
- size_t len, limit = TCL_INDEX_NONE;
- const char *bytes = Tcl_GetString(objv[1]);
- size_t numBytes = objv[1]->length;
+ size_t numBytes, len, limit = TCL_INDEX_NONE;
+ const char *bytes = Tcl_GetStringFromObj(objv[1], &numBytes);
if (objc > 2) {
if (Tcl_GetIntForIndex(interp, objv[2], numBytes, &limit) != TCL_OK) {
@@ -7114,7 +7365,7 @@ TestFindFirstCmd(
if (objc > 2) {
(void) Tcl_GetIntFromObj(interp, objv[2], &len);
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindFirst(Tcl_GetString(objv[1]), len), -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindFirst(Tcl_GetString(objv[1]), len), TCL_INDEX_NONE));
}
return TCL_OK;
}
@@ -7136,7 +7387,7 @@ TestFindLastCmd(
if (objc > 2) {
(void) Tcl_GetIntFromObj(interp, objv[2], &len);
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindLast(Tcl_GetString(objv[1]), len), -1));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindLast(Tcl_GetString(objv[1]), len), TCL_INDEX_NONE));
}
return TCL_OK;
}
@@ -7214,7 +7465,7 @@ TestcpuidCmd(
status = TclWinCPUID(index, regs);
if (status != TCL_OK) {
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("operation not available", -1));
+ Tcl_NewStringObj("operation not available", TCL_INDEX_NONE));
return status;
}
for (i=0 ; i<4 ; ++i) {
@@ -7260,7 +7511,7 @@ TestHashSystemHashCmd(
hPtr = Tcl_CreateHashEntry(&hash, INT2PTR(i), &isNew);
if (!isNew) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i));
- Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem",-1);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem", TCL_INDEX_NONE);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
@@ -7277,13 +7528,13 @@ TestHashSystemHashCmd(
hPtr = Tcl_FindHashEntry(&hash, (char *) INT2PTR(i));
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i));
- Tcl_AppendToObj(Tcl_GetObjResult(interp)," lookup problem",-1);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp)," lookup problem", TCL_INDEX_NONE);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
if (PTR2INT(Tcl_GetHashValue(hPtr)) != i+42) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(i));
- Tcl_AppendToObj(Tcl_GetObjResult(interp)," value problem",-1);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp)," value problem", TCL_INDEX_NONE);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
@@ -7465,15 +7716,15 @@ TestconcatobjCmd(
*/
Tcl_SetObjResult(interp,
- Tcl_NewStringObj("Tcl_ConcatObj is unsafe:", -1));
+ Tcl_NewStringObj("Tcl_ConcatObj is unsafe:", TCL_INDEX_NONE));
emptyPtr = Tcl_NewObj();
- list1Ptr = Tcl_NewStringObj("foo bar sum", -1);
+ list1Ptr = Tcl_NewStringObj("foo bar sum", TCL_INDEX_NONE);
Tcl_ListObjLength(NULL, list1Ptr, &len);
Tcl_InvalidateStringRep(list1Ptr);
- list2Ptr = Tcl_NewStringObj("eeny meeny", -1);
+ list2Ptr = Tcl_NewStringObj("eeny meeny", TCL_INDEX_NONE);
Tcl_ListObjLength(NULL, list2Ptr, &len);
Tcl_InvalidateStringRep(list2Ptr);
@@ -8036,7 +8287,7 @@ InterpCompiledVarResolver(
resVarInfo->vInfo.fetchProc = MyCompiledVarFetch;
resVarInfo->vInfo.deleteProc = MyCompiledVarFree;
resVarInfo->var = NULL;
- resVarInfo->nameObj = Tcl_NewStringObj(name, -1);
+ resVarInfo->nameObj = Tcl_NewStringObj(name, TCL_INDEX_NONE);
Tcl_IncrRefCount(resVarInfo->nameObj);
*rPtr = &resVarInfo->vInfo;
return TCL_OK;
@@ -8120,12 +8371,12 @@ int TestApplyLambdaObjCmd (
/* Create a lambda {{} {set a 42}} */
lambdaObjs[0] = Tcl_NewObj(); /* No parameters */
- lambdaObjs[1] = Tcl_NewStringObj("set a 42", -1); /* Body */
+ lambdaObjs[1] = Tcl_NewStringObj("set a 42", TCL_INDEX_NONE); /* Body */
lambdaObj = Tcl_NewListObj(2, lambdaObjs);
Tcl_IncrRefCount(lambdaObj);
/* Create the command "apply {{} {set a 42}" */
- evalObjs[0] = Tcl_NewStringObj("apply", -1);
+ evalObjs[0] = Tcl_NewStringObj("apply", TCL_INDEX_NONE);
Tcl_IncrRefCount(evalObjs[0]);
/*
* NOTE: IMPORTANT TO EXHIBIT THE BUG. We duplicate the lambda because
generated by cgit v0.12 at 2025-08-30 05:16:12 (GMT)