summaryrefslogtreecommitdiffstats
path: root/generic/tclTest.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclTest.c')
-rw-r--r--generic/tclTest.c474
1 files changed, 405 insertions, 69 deletions
diff --git a/generic/tclTest.c b/generic/tclTest.c
index bac0c7f..a27c95a 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -15,14 +15,14 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
-#include <math.h>
-
#undef STATIC_BUILD
#ifndef USE_TCL_STUBS
# define USE_TCL_STUBS
#endif
#include "tclInt.h"
#include "tclOO.h"
+#include <math.h>
+
/*
* Required for Testregexp*Cmd
*/
@@ -75,6 +75,8 @@ typedef struct TestAsyncHandler {
/* Next is list of handlers. */
} TestAsyncHandler;
+TCL_DECLARE_MUTEX(asyncTestMutex)
+
static TestAsyncHandler *firstHandler = NULL;
/*
@@ -306,9 +308,8 @@ static int TestexitmainloopCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestpanicCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
-static int TestfinexitObjCmd(ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+static int TestparseargsCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
static int TestparserObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -326,10 +327,12 @@ static int TestreturnObjCmd(ClientData dummy,
Tcl_Obj *const objv[]);
static void TestregexpXflags(const char *string,
int length, int *cflagsPtr, int *eflagsPtr);
+#ifndef TCL_NO_DEPRECATED
static int TestsaveresultCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static void TestsaveresultFree(char *blockPtr);
+#endif /* TCL_NO_DEPRECATED */
static int TestsetassocdataCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestsetCmd(ClientData dummy,
@@ -380,7 +383,8 @@ static Tcl_FSRenameFileProc TestReportRenameFile;
static Tcl_FSCreateDirectoryProc TestReportCreateDirectory;
static Tcl_FSCopyDirectoryProc TestReportCopyDirectory;
static Tcl_FSRemoveDirectoryProc TestReportRemoveDirectory;
-static Tcl_FSLoadFileProc TestReportLoadFile;
+static int TestReportLoadFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
+ Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr);
static Tcl_FSLinkProc TestReportLink;
static Tcl_FSFileAttrStringsProc TestReportFileAttrStrings;
static Tcl_FSFileAttrsGetProc TestReportFileAttrsGet;
@@ -407,6 +411,14 @@ static int TestHashSystemHashCmd(ClientData clientData,
static int TestNRELevels(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+static int TestInterpResolverCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+#if defined(HAVE_CPUID) || defined(_WIN32)
+static int TestcpuidCmd(ClientData dummy,
+ Tcl_Interp* interp, int objc,
+ Tcl_Obj *const objv[]);
+#endif
static const Tcl_Filesystem testReportingFilesystem = {
"reporting",
@@ -437,7 +449,7 @@ static const Tcl_Filesystem testReportingFilesystem = {
TestReportRenameFile,
TestReportCopyDirectory,
TestReportLstat,
- TestReportLoadFile,
+ (Tcl_FSLoadFileProc *) TestReportLoadFile,
NULL /* cwd */,
TestReportChdir
};
@@ -513,7 +525,9 @@ int
Tcltest_Init(
Tcl_Interp *interp) /* Interpreter for application. */
{
+#ifndef TCL_NO_DEPRECATED
Tcl_ValueType t3ArgTypes[2];
+#endif /* TCL_NO_DEPRECATED */
Tcl_Obj *listPtr;
Tcl_Obj **objv;
@@ -621,7 +635,7 @@ Tcltest_Init(
Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL);
- Tcl_CreateObjCommand(interp, "testfinexit", TestfinexitObjCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL);
Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd,
@@ -632,8 +646,10 @@ Tcltest_Init(
NULL, NULL);
Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd,
NULL, NULL);
+#ifndef TCL_NO_DEPRECATED
Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd,
NULL, NULL);
+#endif /* TCL_NO_DEPRECATED */
Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
@@ -655,21 +671,31 @@ Tcltest_Init(
Tcl_CreateCommand(interp, "testtranslatefilename",
TesttranslatefilenameCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, NULL, NULL);
+#ifndef TCL_NO_DEPRECATED
Tcl_CreateMathFunc(interp, "T1", 0, NULL, TestMathFunc, (ClientData) 123);
Tcl_CreateMathFunc(interp, "T2", 0, NULL, TestMathFunc, (ClientData) 345);
+#endif /* TCL_NO_DEPRECATED */
Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd,
NULL, NULL);
+#if defined(HAVE_CPUID) || defined(_WIN32)
+ Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd,
+ (ClientData) 0, NULL);
+#endif
+#ifndef TCL_NO_DEPRECATED
t3ArgTypes[0] = TCL_EITHER;
t3ArgTypes[1] = TCL_EITHER;
Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2,
NULL);
+#endif /* TCL_NO_DEPRECATED */
Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels,
NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd,
+ NULL, NULL);
if (TclObjTest_Init(interp) != TCL_OK) {
return TCL_ERROR;
@@ -791,17 +817,20 @@ TestasyncCmd(
goto wrongNumArgs;
}
asyncPtr = ckalloc(sizeof(TestAsyncHandler));
+ asyncPtr->command = ckalloc(strlen(argv[2]) + 1);
+ strcpy(asyncPtr->command, argv[2]);
+ Tcl_MutexLock(&asyncTestMutex);
asyncPtr->id = nextId;
nextId++;
asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc,
- (ClientData) asyncPtr);
- asyncPtr->command = ckalloc(strlen(argv[2]) + 1);
- strcpy(asyncPtr->command, argv[2]);
+ INT2PTR(asyncPtr->id));
asyncPtr->nextPtr = firstHandler;
firstHandler = asyncPtr;
+ Tcl_MutexUnlock(&asyncTestMutex);
Tcl_SetObjResult(interp, Tcl_NewIntObj(asyncPtr->id));
} else if (strcmp(argv[1], "delete") == 0) {
if (argc == 2) {
+ Tcl_MutexLock(&asyncTestMutex);
while (firstHandler != NULL) {
asyncPtr = firstHandler;
firstHandler = asyncPtr->nextPtr;
@@ -809,6 +838,7 @@ TestasyncCmd(
ckfree(asyncPtr->command);
ckfree(asyncPtr);
}
+ Tcl_MutexUnlock(&asyncTestMutex);
return TCL_OK;
}
if (argc != 3) {
@@ -817,6 +847,7 @@ TestasyncCmd(
if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) {
return TCL_ERROR;
}
+ Tcl_MutexLock(&asyncTestMutex);
for (prevPtr = NULL, asyncPtr = firstHandler; asyncPtr != NULL;
prevPtr = asyncPtr, asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id != id) {
@@ -832,6 +863,7 @@ TestasyncCmd(
ckfree(asyncPtr);
break;
}
+ Tcl_MutexUnlock(&asyncTestMutex);
} else if (strcmp(argv[1], "mark") == 0) {
if (argc != 5) {
goto wrongNumArgs;
@@ -840,6 +872,7 @@ TestasyncCmd(
|| (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) {
return TCL_ERROR;
}
+ Tcl_MutexLock(&asyncTestMutex);
for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id == id) {
@@ -848,6 +881,7 @@ TestasyncCmd(
}
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1));
+ Tcl_MutexUnlock(&asyncTestMutex);
return code;
#ifdef TCL_THREADS
} else if (strcmp(argv[1], "marklater") == 0) {
@@ -857,19 +891,22 @@ TestasyncCmd(
if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) {
return TCL_ERROR;
}
+ Tcl_MutexLock(&asyncTestMutex);
for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id == id) {
Tcl_ThreadId threadID;
if (Tcl_CreateThread(&threadID, AsyncThreadProc,
- (ClientData) asyncPtr, TCL_THREAD_STACK_DEFAULT,
+ INT2PTR(id), TCL_THREAD_STACK_DEFAULT,
TCL_THREAD_NOFLAGS) != TCL_OK) {
Tcl_SetResult(interp, "can't create thread", TCL_STATIC);
+ Tcl_MutexUnlock(&asyncTestMutex);
return TCL_ERROR;
}
break;
}
}
+ Tcl_MutexUnlock(&asyncTestMutex);
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be create, delete, int, mark, or marklater", NULL);
@@ -886,15 +923,29 @@ TestasyncCmd(
static int
AsyncHandlerProc(
- ClientData clientData, /* Pointer to TestAsyncHandler structure. */
+ ClientData clientData, /* If of TestAsyncHandler structure.
+ * in global list. */
Tcl_Interp *interp, /* Interpreter in which command was
* executed, or NULL. */
int code) /* Current return code from command. */
{
- TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData;
+ TestAsyncHandler *asyncPtr;
+ int id = PTR2INT(clientData);
const char *listArgv[4], *cmd;
char string[TCL_INTEGER_SPACE];
+ Tcl_MutexLock(&asyncTestMutex);
+ for (asyncPtr = firstHandler; asyncPtr != NULL;
+ asyncPtr = asyncPtr->nextPtr) {
+ if (asyncPtr->id == id) break;
+ }
+ Tcl_MutexUnlock(&asyncTestMutex);
+
+ if (!asyncPtr) {
+ /* Woops - this one was deleted between the AsyncMark and now */
+ return TCL_OK;
+ }
+
TclFormatInt(string, code);
listArgv[0] = asyncPtr->command;
listArgv[1] = Tcl_GetString(Tcl_GetObjResult(interp));
@@ -932,12 +983,22 @@ AsyncHandlerProc(
#ifdef TCL_THREADS
static Tcl_ThreadCreateType
AsyncThreadProc(
- ClientData clientData) /* Parameter is a pointer to a
+ ClientData clientData) /* Parameter is the id of a
* TestAsyncHandler, defined above. */
{
- TestAsyncHandler *asyncPtr = clientData;
+ TestAsyncHandler *asyncPtr;
+ int id = PTR2INT(clientData);
+
Tcl_Sleep(1);
- Tcl_AsyncMark(asyncPtr->handler);
+ Tcl_MutexLock(&asyncTestMutex);
+ for (asyncPtr = firstHandler; asyncPtr != NULL;
+ asyncPtr = asyncPtr->nextPtr) {
+ if (asyncPtr->id == id) {
+ Tcl_AsyncMark(asyncPtr->handler);
+ break;
+ }
+ }
+ Tcl_MutexUnlock(&asyncTestMutex);
Tcl_ExitThread(TCL_OK);
TCL_THREAD_CREATE_RETURN;
}
@@ -1494,14 +1555,14 @@ DelCallbackProc(
*
* TestdelCmd --
*
- * This procedure implements the "testdcall" command. It is used
- * to test Tcl_CallWhenDeleted.
+ * This procedure implements the "testdel" command. It is used
+ * to test calling of command deletion callbacks.
*
* Results:
* A standard Tcl result.
*
* Side effects:
- * Creates and deletes interpreters.
+ * Creates a command.
*
*----------------------------------------------------------------------
*/
@@ -1795,7 +1856,7 @@ TestdstringCmd(
if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) {
return TCL_ERROR;
}
- Tcl_DStringTrunc(&dstring, count);
+ Tcl_DStringSetLength(&dstring, count);
} else if (strcmp(argv[1], "start") == 0) {
if (argc != 2) {
goto wrongNumArgs;
@@ -3217,7 +3278,7 @@ TestlocaleCmd(
"ctype", "numeric", "time", "collate", "monetary",
"all", NULL
};
- static int lcTypes[] = {
+ static const int lcTypes[] = {
LC_CTYPE, LC_NUMERIC, LC_TIME, LC_COLLATE, LC_MONETARY,
LC_ALL
};
@@ -4347,8 +4408,26 @@ TestseterrorcodeCmd(
Tcl_SetResult(interp, "too many args", TCL_STATIC);
return TCL_ERROR;
}
- Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4],
- argv[5], NULL);
+ switch (argc) {
+ case 1:
+ Tcl_SetErrorCode(interp, "NONE", NULL);
+ break;
+ case 2:
+ Tcl_SetErrorCode(interp, argv[1], NULL);
+ break;
+ case 3:
+ Tcl_SetErrorCode(interp, argv[1], argv[2], NULL);
+ break;
+ case 4:
+ Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], NULL);
+ break;
+ case 5:
+ Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], NULL);
+ break;
+ case 6:
+ Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4],
+ argv[5], NULL);
+ }
return TCL_ERROR;
}
@@ -4493,47 +4572,6 @@ TestpanicCmd(
return TCL_OK;
}
-/*
- *----------------------------------------------------------------------
- *
- * TestfinexitObjCmd --
- *
- * Calls a variant of [exit] including the full finalization path.
- *
- * Results:
- * Error, or doesn't return.
- *
- * Side effects:
- * Exits application.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-TestfinexitObjCmd(
- ClientData dummy, /* Not used. */
- Tcl_Interp *interp, /* Current interpreter. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument objects. */
-{
- int value;
-
- if ((objc != 1) && (objc != 2)) {
- Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?");
- return TCL_ERROR;
- }
-
- if (objc == 1) {
- value = 0;
- } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) {
- return TCL_ERROR;
- }
- Tcl_Finalize();
- TclpExit(value);
- /*NOTREACHED*/
- return TCL_ERROR; /* Better not ever reach this! */
-}
-
static int
TestfileCmd(
ClientData dummy, /* Not used. */
@@ -4993,6 +5031,7 @@ Testset2Cmd(
}
}
+#ifndef TCL_NO_DEPRECATED
/*
*----------------------------------------------------------------------
*
@@ -5126,6 +5165,7 @@ TestsaveresultFree(
{
freeCount++;
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -6160,7 +6200,7 @@ TestReport(
* API, but there you go. We should convert it to objects.
*/
- Tcl_SavedResult savedResult;
+ Tcl_Obj *savedResult;
Tcl_DString ds;
Tcl_DStringInit(&ds);
@@ -6174,11 +6214,15 @@ TestReport(
Tcl_DStringAppendElement(&ds, Tcl_GetString(arg2));
}
Tcl_DStringEndSublist(&ds);
- Tcl_SaveResult(interp, &savedResult);
+ savedResult = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(savedResult);
+ Tcl_SetObjResult(interp, Tcl_NewObj());
Tcl_Eval(interp, Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
- Tcl_RestoreResult(interp, &savedResult);
- }
+ Tcl_ResetResult(interp);
+ Tcl_SetObjResult(interp, savedResult);
+ Tcl_DecrRefCount(savedResult);
+ }
}
static int
@@ -6603,6 +6647,62 @@ TestNumUtfCharsCmd(
}
return TCL_OK;
}
+
+#if defined(HAVE_CPUID) || defined(_WIN32)
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestcpuidCmd --
+ *
+ * Retrieves CPU ID information.
+ *
+ * Usage:
+ * testwincpuid <eax>
+ *
+ * Parameters:
+ * eax - The value to pass in the EAX register to a CPUID instruction.
+ *
+ * Results:
+ * Returns a four-element list containing the values from the EAX, EBX,
+ * ECX and EDX registers returned from the CPUID instruction.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestcpuidCmd(
+ ClientData dummy,
+ Tcl_Interp* interp, /* Tcl interpreter */
+ int objc, /* Parameter count */
+ Tcl_Obj *const * objv) /* Parameter vector */
+{
+ int status, index, i;
+ unsigned int regs[4];
+ Tcl_Obj *regsObjs[4];
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "eax");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[1], &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ status = TclWinCPUID((unsigned) index, regs);
+ if (status != TCL_OK) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("operation not available", -1));
+ return status;
+ }
+ for (i=0 ; i<4 ; ++i) {
+ regsObjs[i] = Tcl_NewIntObj((int) regs[i]);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs));
+ return TCL_OK;
+}
+#endif
/*
* Used to do basic checks of the TCL_HASH_KEY_SYSTEM_HASH flag
@@ -7050,9 +7150,245 @@ TestconcatobjCmd(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * TestparseargsCmd --
+ *
+ * This procedure implements the "testparseargs" command. It is used to
+ * test that Tcl_ParseArgsObjv does indeed return the right number of
+ * arguments. In other words, that [Bug 3413857] was fixed properly.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestparseargsCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Arguments. */
+{
+ static int foo = 0;
+ int count = objc;
+ Tcl_Obj **remObjv, *result[3];
+ Tcl_ArgvInfo argTable[] = {
+ {TCL_ARGV_CONSTANT, "-bool", INT2PTR(1), &foo, "booltest", NULL},
+ TCL_ARGV_AUTO_REST, TCL_ARGV_AUTO_HELP, TCL_ARGV_TABLE_END
+ };
+
+ foo = 0;
+ if (Tcl_ParseArgsObjv(interp, argTable, &count, objv, &remObjv)!=TCL_OK) {
+ return TCL_ERROR;
+ }
+ result[0] = Tcl_NewIntObj(foo);
+ result[1] = Tcl_NewIntObj(count);
+ result[2] = Tcl_NewListObj(count, remObjv);
+ Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
+ ckfree(remObjv);
+ return TCL_OK;
+}
+
+/**
+ * Test harness for command and variable resolvers.
+ */
+
+static int
+InterpCmdResolver(
+ Tcl_Interp *interp,
+ const char *name,
+ Tcl_Namespace *context,
+ int flags,
+ Tcl_Command *rPtr)
+{
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *varFramePtr = iPtr->varFramePtr;
+ Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ?
+ varFramePtr->procPtr : NULL;
+ Namespace *ns2NsPtr = (Namespace *)
+ Tcl_FindNamespace(interp, "::ns2", NULL, 0);
+
+ if (procPtr && (procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr
+ || (ns2NsPtr && procPtr->cmdPtr->nsPtr == ns2NsPtr))) {
+ const char *callingCmdName =
+ Tcl_GetCommandName(interp, (Tcl_Command) procPtr->cmdPtr);
+
+ if ((callingCmdName[0] == 'x') && (callingCmdName[1] == '\0')
+ && (name[0] == 'z') && (name[1] == '\0')) {
+ Tcl_Command sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL,
+ TCL_GLOBAL_ONLY);
+
+ if (sourceCmdPtr != NULL) {
+ *rPtr = sourceCmdPtr;
+ return TCL_OK;
+ }
+ }
+ }
+ return TCL_CONTINUE;
+}
+
+static int
+InterpVarResolver(
+ Tcl_Interp *interp,
+ const char *name,
+ Tcl_Namespace *context,
+ int flags,
+ Tcl_Var *rPtr)
+{
+ /*
+ * Don't resolve the variable; use standard rules.
+ */
+
+ return TCL_CONTINUE;
+}
+
+typedef struct MyResolvedVarInfo {
+ Tcl_ResolvedVarInfo vInfo; /* This must be the first element. */
+ Tcl_Var var;
+ Tcl_Obj *nameObj;
+} MyResolvedVarInfo;
+
+static inline void
+HashVarFree(
+ Tcl_Var var)
+{
+ if (VarHashRefCount(var) < 2) {
+ ckfree(var);
+ } else {
+ VarHashRefCount(var)--;
+ }
+}
+
+static void
+MyCompiledVarFree(
+ Tcl_ResolvedVarInfo *vInfoPtr)
+{
+ MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *) vInfoPtr;
+
+ Tcl_DecrRefCount(resVarInfo->nameObj);
+ if (resVarInfo->var) {
+ HashVarFree(resVarInfo->var);
+ }
+ ckfree(vInfoPtr);
+}
+
+#define TclVarHashGetValue(hPtr) \
+ ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))
+
+static Tcl_Var
+MyCompiledVarFetch(
+ Tcl_Interp *interp,
+ Tcl_ResolvedVarInfo *vinfoPtr)
+{
+ MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *) vinfoPtr;
+ Tcl_Var var = resVarInfo->var;
+ int isNewVar;
+ Interp *iPtr = (Interp *) interp;
+ Tcl_HashEntry *hPtr;
+
+ if (var != NULL) {
+ if (!(((Var *) var)->flags & VAR_DEAD_HASH)) {
+ /*
+ * The cached variable is valid, return it.
+ */
+
+ return var;
+ }
+
+ /*
+ * The variable is not valid anymore. Clean it up.
+ */
+
+ HashVarFree(var);
+ }
+
+ hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) &iPtr->globalNsPtr->varTable,
+ (char *) resVarInfo->nameObj, &isNewVar);
+ if (hPtr) {
+ var = (Tcl_Var) TclVarHashGetValue(hPtr);
+ } else {
+ var = NULL;
+ }
+ resVarInfo->var = var;
+
+ /*
+ * Increment the reference counter to avoid ckfree() of the variable in
+ * Tcl's FreeVarEntry(); for cleanup, we provide our own HashVarFree();
+ */
+
+ VarHashRefCount(var)++;
+ return var;
+}
+
+static int
+InterpCompiledVarResolver(
+ Tcl_Interp *interp,
+ const char *name,
+ int length,
+ Tcl_Namespace *context,
+ Tcl_ResolvedVarInfo **rPtr)
+{
+ if (*name == 'T') {
+ MyResolvedVarInfo *resVarInfo = ckalloc(sizeof(MyResolvedVarInfo));
+
+ resVarInfo->vInfo.fetchProc = MyCompiledVarFetch;
+ resVarInfo->vInfo.deleteProc = MyCompiledVarFree;
+ resVarInfo->var = NULL;
+ resVarInfo->nameObj = Tcl_NewStringObj(name, -1);
+ Tcl_IncrRefCount(resVarInfo->nameObj);
+ *rPtr = &resVarInfo->vInfo;
+ return TCL_OK;
+ }
+ return TCL_CONTINUE;
+}
+
+static int
+TestInterpResolverCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ static const char *const table[] = {
+ "down", "up", NULL
+ };
+ int idx;
+#define RESOLVER_KEY "testInterpResolver"
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "up|down");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], table, "operation", TCL_EXACT,
+ &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (idx) {
+ case 1: /* up */
+ Tcl_AddInterpResolvers(interp, RESOLVER_KEY, InterpCmdResolver,
+ InterpVarResolver, InterpCompiledVarResolver);
+ break;
+ case 0: /*down*/
+ if (!Tcl_RemoveInterpResolvers(interp, RESOLVER_KEY)) {
+ Tcl_AppendResult(interp, "could not remove the resolver scheme",
+ NULL);
+ return TCL_ERROR;
+ }
+ }
+ return TCL_OK;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
+ * tab-width: 8
+ * indent-tabs-mode: nil
* End:
*/
generated by cgit v0.12 at 2025-10-31 09:27:01 (GMT)